Commit 18077d95 authored by Jonas Maebe's avatar Jonas Maebe
Browse files

* when determining the best candidates for overloaded method calls, apply

    the scope penalty relative to the nearest symtable that contains one of
    the applicable overloads, rather than relative to the nearest symtable
    that simply contains a method with this name (based on patch by
    Maciej Izak, mantis #25607)

git-svn-id: trunk@35089 -
parent 04f7e47d
......@@ -14953,6 +14953,12 @@ tests/webtbs/tw25603.pp svneol=native#text/pascal
tests/webtbs/tw25604.pp svneol=native#text/pascal
tests/webtbs/tw25605.pp svneol=native#text/pascal
tests/webtbs/tw25606.pp svneol=native#text/pascal
tests/webtbs/tw25607a.pp -text svneol=native#text/plain
tests/webtbs/tw25607b.pp -text svneol=native#text/plain
tests/webtbs/tw25607c.pp -text svneol=native#text/plain
tests/webtbs/tw25607d.pp -text svneol=native#text/plain
tests/webtbs/tw25607e.pp -text svneol=native#text/plain
tests/webtbs/tw25607f.pp -text svneol=native#text/plain
tests/webtbs/tw2561.pp svneol=native#text/plain
tests/webtbs/tw25610.pp -text svneol=native#text/plain
tests/webtbs/tw25685.pp svneol=native#text/pascal
......
......@@ -73,6 +73,7 @@ tcallcandidates = class
procedure collect_overloads_in_struct(structdef:tabstractrecorddef;ProcdefOverloadList:TFPObjectList;searchhelpers,anoninherited:boolean;spezcontext:tspecializationcontext);
procedure collect_overloads_in_units(ProcdefOverloadList:TFPObjectList; objcidcall,explicitunit: boolean;spezcontext:tspecializationcontext);
procedure create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited:boolean;spezcontext:tspecializationcontext);
procedure calc_distance(st_root:tsymtable;objcidcall: boolean);
function proc_add(st:tsymtable;pd:tprocdef;objcidcall: boolean):pcandidate;
function maybe_specialize(var pd:tprocdef;spezcontext:tspecializationcontext):boolean;
public
......@@ -2549,10 +2550,93 @@ if (pt.resultdef.typ=recorddef) and
end;
end;
calc_distance(st,objcidcall);
ProcdefOverloadList.Free;
end;
procedure tcallcandidates.calc_distance(st_root: tsymtable; objcidcall: boolean);
var
pd:tprocdef;
candidate:pcandidate;
objdef: tobjectdef;
st: tsymtable;
begin
{ Give a small penalty for overloaded methods not defined in the
current class/unit }
st:=nil;
if objcidcall or
not assigned(st_root) or
not assigned(st_root.defowner) or
(st_root.defowner.typ<>objectdef) then
st:=st_root
else
repeat
{ In case of a method, st_root is the symtable of the first found
procsym with the called method's name, but this procsym may not
contain any of the overloads that match the used parameters (which
are the procdefs that have been collected as candidates) -> walk
up the class hierarchy and look for the first class that actually
defines at least one of the candidate procdefs.
The reason is that we will penalise methods in other classes/
symtables, so if we pick a symtable that does not contain any of
the candidates, this won't help with picking the best/
most-inner-scoped one (since all of them will be penalised) }
candidate:=FCandidateProcs;
{ the current class contains one of the candidates? }
while assigned(candidate) do
begin
pd:=candidate^.data;
if pd.owner=st_root then
begin
{ yes -> choose this class }
st:=st_root;
break;
end;
candidate:=candidate^.next;
end;
{ None found -> go to parent class }
if not assigned(st) then
begin
if not assigned(st_root.defowner) then
internalerror(201605301);
{ no more parent class -> take current class as root anyway
(could maybe happen in case of a class helper?) }
if not assigned(tobjectdef(st_root.defowner).childof) then
begin
st:=st_root;
break;
end;
st_root:=tobjectdef(st_root.defowner).childof.symtable;
end;
until assigned(st);
candidate:=FCandidateProcs;
{ when calling Objective-C methods via id.method, then the found
procsym will be inside an arbitrary ObjectSymtable, and we don't
want to give the methods of that particular objcclass precedence
over other methods, so instead check against the symtable in
which this objcclass is defined }
if objcidcall then
st:=st.defowner.owner;
while assigned(candidate) do
begin
pd:=candidate^.data;
if st<>pd.owner then
candidate^.ordinal_distance:=candidate^.ordinal_distance+1.0;
candidate:=candidate^.next;
end;
end;
function tcallcandidates.proc_add(st:tsymtable;pd:tprocdef;objcidcall: boolean):pcandidate;
var
defaultparacnt : integer;
......@@ -2580,17 +2664,6 @@ if (pt.resultdef.typ=recorddef) and
dec(result^.firstparaidx,defaultparacnt);
end;
end;
{ Give a small penalty for overloaded methods not in
defined the current class/unit }
{ when calling Objective-C methods via id.method, then the found
procsym will be inside an arbitrary ObjectSymtable, and we don't
want togive the methods of that particular objcclass precedence over
other methods, so instead check against the symtable in which this
objcclass is defined }
if objcidcall then
st:=st.defowner.owner;
if (st<>pd.owner) then
result^.ordinal_distance:=result^.ordinal_distance+1.0;
end;
......
program E01;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$APPTYPE CONSOLE}
type
TA = class
constructor Create(A: Integer = 0); overload; virtual;
end;
TB = class(TA)
constructor Create(A: Integer); overload; override;
end;
TClassB = class of TB;
var
tacalled,
tbcalled: boolean;
constructor TA.Create(A: Integer = 0);
begin
WriteLn('TA.Create');
tacalled:=true;
end;
constructor TB.Create(A: Integer);
begin
WriteLn('TB.Create');
tbcalled:=true;
end;
var
B: TB;
ClassB: TClassB;
begin
B := TB.Create; // TA.Create (VMT is not used
// compiler can determine) -- in Delphi;
// In FPC, because TB.Create is used, we
// call TB.Create
if tacalled then
halt(1);
if not tbcalled then
halt(2);
tbcalled:=false;
B.Create; // call TB.Create because of VMT rules
B.Free;
if tacalled then
halt(3);
if not tbcalled then
halt(4);
tbcalled:=false;
ClassB := TB;
B := ClassB.Create; // call TB.Create because of VMT rules
B.Free;
if tacalled then
halt(5);
if not tbcalled then
halt(6);
end.
program E02;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$APPTYPE CONSOLE}
type
TA = class
constructor Create(A: Integer = 0); overload;
end;
TB = class(TA)
constructor Create(A: Integer); overload;
end;
TClassB = class of TB;
var
tacalled,
tbcalled: boolean;
constructor TA.Create(A: Integer = 0);
begin
WriteLn('TA.Create');
tacalled:=true;
end;
constructor TB.Create(A: Integer);
begin
WriteLn('TB.Create');
tbcalled:=true;
end;
var
B: TB;
ClassB: TClassB;
begin
B := TB.Create; // TA.Create (VMT is not used
// compiler can determine)
if not tacalled then
halt(1);
if tbcalled then
halt(2);
tacalled:=false;
B.Create; // call TA.Create because of VMT rules
B.Free;
if not tacalled then
halt(3);
if tbcalled then
halt(4);
tacalled:=false;
ClassB := TB;
B := ClassB.Create; // call TA.Create because of VMT rules
B.Free;
if not tacalled then
halt(5);
if tbcalled then
halt(6);
tacalled:=false;
end.
program E03;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$APPTYPE CONSOLE}
type
T0 = class
class procedure Foo;
end;
TA = class(T0)
class procedure Foo(A: Integer = 0); overload; virtual;
end;
TB = class(TA)
class procedure Foo(A: Integer); overload; override;
end;
TClassB = class of TB;
var
t0called,
tacalled,
tbcalled: boolean;
class procedure T0.Foo();
begin
WriteLn('T0.Foo');
t0called:=true;
end;
class procedure TA.Foo(A: Integer = 0);
begin
WriteLn('TA.Foo');
tacalled:=true;
end;
class procedure TB.Foo(A: Integer);
begin
WriteLn('TB.Foo');
tbcalled:=true;
end;
var
B: TB;
ClassB: TClassB;
begin
TB.Foo; // call TA.Foo (VMT is not used, compiler can determine) -- on Delphi
// on FPC: call TB.Foo because virtual method and VMT specified
if t0called then
halt(1);
if tacalled then
halt(2);
if not tbcalled then
halt(3);
tbcalled:=false;
B := TB.Create;
B.Foo; // call TB.Foo because of VMT rules
B.Free;
if t0called then
halt(4);
if tacalled then
halt(5);
if not tbcalled then
halt(6);
tbcalled:=false;
ClassB := TB;
ClassB.Foo; // call TB.Foo because of VMT rules
if t0called then
halt(7);
if tacalled then
halt(8);
if not tbcalled then
halt(9);
tbcalled:=false;
end.
\ No newline at end of file
program E04;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$APPTYPE CONSOLE}
type
T0 = class
class procedure Foo;
end;
TA = class(T0)
class procedure Foo(A: Integer = 0); overload;
end;
TB = class(TA)
class procedure Foo(A: Integer); overload;
end;
TClassB = class of TB;
var
t0called,
tacalled,
tbcalled: boolean;
class procedure T0.Foo();
begin
WriteLn('T0.Foo');
t0called:=true;
end;
class procedure TA.Foo(A: Integer = 0);
begin
WriteLn('TA.Foo');
tacalled:=true;
end;
class procedure TB.Foo(A: Integer);
begin
WriteLn('TB.Foo');
tbcalled:=true;
end;
var
B: TB;
ClassB: TClassB;
begin
TB.Foo; // call TA.Foo (VMT is not used, compiler can determine)
if t0called then
halt(1);
if not tacalled then
halt(2);
if tbcalled then
halt(3);
tacalled:=false;
B := TB.Create;
B.Foo; // call TA.Foo because of VMT rules
B.Free;
if t0called then
halt(4);
if not tacalled then
halt(5);
if tbcalled then
halt(6);
tacalled:=false;
ClassB := TB;
ClassB.Foo; // call TA.Foo because of VMT rules
if t0called then
halt(7);
if not tacalled then
halt(8);
if tbcalled then
halt(9);
end.
program E05;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$APPTYPE CONSOLE}
type
T0 = class
procedure Foo;
end;
TA = class(T0)
procedure Foo(A: Integer = 0); overload; virtual;
end;
TB = class(TA)
procedure Foo(A: Integer); overload; override;
end;
TClassB = class of TB;
var
t0called,
tacalled,
tbcalled: boolean;
procedure T0.Foo();
begin
WriteLn('T0.Foo');
t0called:=true;
end;
procedure TA.Foo(A: Integer = 0);
begin
WriteLn('TA.Foo');
tacalled:=true;
end;
procedure TB.Foo(A: Integer);
begin
WriteLn('TB.Foo');
tbcalled:=true;
end;
var
B: TB;
ClassB: TClassB;
begin
B := TB.Create;
B.Foo; // call TB.Foo because of VMT rules
B.Free;
if t0called then
halt(1);
if tacalled then
halt(2);
if not tbcalled then
halt(3);
end.
\ No newline at end of file
program E06;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$APPTYPE CONSOLE}
type
T0 = class
procedure Foo;
end;
TA = class(T0)
procedure Foo(A: Integer = 0); overload;
end;
TB = class(TA)
procedure Foo(A: Integer); overload;
end;
TClassB = class of TB;
var
t0called,
tacalled,
tbcalled: boolean;
procedure T0.Foo();
begin
WriteLn('T0.Foo');
t0called:=true;
end;
procedure TA.Foo(A: Integer = 0);
begin
WriteLn('TA.Foo');
tacalled:=true;
end;
procedure TB.Foo(A: Integer);
begin
WriteLn('TB.Foo');
tbcalled:=true;
end;
var
B: TB;
ClassB: TClassB;
begin
B := TB.Create;
B.Foo; // call TA.Foo because of VMT rules
B.Free;
if t0called then
halt(1);
if not tacalled then
halt(2);
if tbcalled then
halt(3);
end.
\ No newline at end of file
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment