* 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 -

.gitattributes

@@ -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

compiler/htypechk.pas

@@ -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;
 
 

tests/webtbs/tw25607a.pp

+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.

tests/webtbs/tw25607b.pp

+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.

tests/webtbs/tw25607c.pp

+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

tests/webtbs/tw25607d.pp

+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.

tests/webtbs/tw25607e.pp

+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

tests/webtbs/tw25607f.pp

+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