mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-15 20:39:24 +02:00
* calculate distance between related objectdefs
git-svn-id: trunk@1492 -
This commit is contained in:
parent
09a0dff4da
commit
260861e184
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -6320,6 +6320,7 @@ tests/webtbs/tw4260.pp svneol=native#text/plain
|
||||
tests/webtbs/tw4266.pp -text
|
||||
tests/webtbs/tw4272.pp svneol=native#text/plain
|
||||
tests/webtbs/tw4277.pp svneol=native#text/plain
|
||||
tests/webtbs/tw4278.pp svneol=native#text/plain
|
||||
tests/webtbs/tw4290.pp svneol=native#text/plain
|
||||
tests/webtbs/tw4294.pp svneol=native#text/plain
|
||||
tests/webtbs/tw4308.pp svneol=native#text/plain
|
||||
|
@ -1737,6 +1737,7 @@ implementation
|
||||
paraidx : integer;
|
||||
currparanr : byte;
|
||||
rfh,rth : bestreal;
|
||||
objdef : tobjectdef;
|
||||
def_from,
|
||||
def_to : tdef;
|
||||
currpt,
|
||||
@ -1862,6 +1863,24 @@ implementation
|
||||
hp^.ordinal_distance:=hp^.ordinal_distance+rfh;
|
||||
end
|
||||
else
|
||||
{ related object parameters also need to determine the distance between the current
|
||||
object and the object we are comparing with }
|
||||
if (def_from.deftype=objectdef) and
|
||||
(def_to.deftype=objectdef) and
|
||||
(tobjectdef(def_from).objecttype=tobjectdef(def_to).objecttype) and
|
||||
tobjectdef(def_from).is_related(tobjectdef(def_to)) then
|
||||
begin
|
||||
eq:=te_convert_l1;
|
||||
objdef:=tobjectdef(def_from);
|
||||
while assigned(objdef) do
|
||||
begin
|
||||
if objdef=def_to then
|
||||
break;
|
||||
hp^.ordinal_distance:=hp^.ordinal_distance+1;
|
||||
objdef:=objdef.childof;
|
||||
end;
|
||||
end
|
||||
else
|
||||
{ generic type comparision }
|
||||
begin
|
||||
eq:=compare_defs_ext(def_from,def_to,currpt.left.nodetype,convtype,pdoper,cdoptions);
|
||||
|
32
tests/webtbs/tw4278.pp
Executable file
32
tests/webtbs/tw4278.pp
Executable file
@ -0,0 +1,32 @@
|
||||
{$mode objfpc}
|
||||
|
||||
var
|
||||
err : boolean;
|
||||
|
||||
type
|
||||
TA = class
|
||||
end;
|
||||
TB = class(TA)
|
||||
end;
|
||||
TC = class(TB)
|
||||
end;
|
||||
|
||||
procedure Test(const A: TA); overload;
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure Test(const B: TB); overload;
|
||||
begin
|
||||
writeln('ok');
|
||||
err:=false;
|
||||
end;
|
||||
|
||||
var
|
||||
X : TC;
|
||||
|
||||
begin
|
||||
err:=true;
|
||||
Test(X);
|
||||
if err then
|
||||
halt(1);
|
||||
end.
|
Loading…
Reference in New Issue
Block a user