Explorar o código

* stop searching for methods to implement interfaces in parent classes after
encountering a method with the correct name that does not have the
"overload" directive (same logic as when looking for a call candidate,
to avoid errors when using a Pascal-level wrapper to call interface
methods, and Delphi-compatible since it always required "overload" for
overloaded methods)
o also catches calling convention mismatches like in webtbs/tw27349

git-svn-id: trunk@40683 -

Jonas Maebe %!s(int64=6) %!d(string=hai) anos
pai
achega
7b313a2c15
Modificáronse 5 ficheiros con 82 adicións e 4 borrados
  1. 2 0
      .gitattributes
  2. 8 0
      compiler/nobj.pas
  3. 34 0
      tests/tbf/tb0267.pp
  4. 34 0
      tests/tbs/tb0654.pp
  5. 4 4
      tests/webtbs/tw27349.pp

+ 2 - 0
.gitattributes

@@ -11087,6 +11087,7 @@ tests/tbf/tb0264.pp svneol=native#text/pascal
 tests/tbf/tb0265.pp svneol=native#text/pascal
 tests/tbf/tb0266a.pp svneol=native#text/pascal
 tests/tbf/tb0266b.pp svneol=native#text/pascal
+tests/tbf/tb0267.pp svneol=native#text/plain
 tests/tbf/tb0588.pp svneol=native#text/pascal
 tests/tbf/ub0115.pp svneol=native#text/plain
 tests/tbf/ub0149.pp svneol=native#text/plain
@@ -11747,6 +11748,7 @@ tests/tbs/tb0650.pp svneol=native#text/pascal
 tests/tbs/tb0651.pp svneol=native#text/pascal
 tests/tbs/tb0652.pp svneol=native#text/pascal
 tests/tbs/tb0653.pp svneol=native#text/plain
+tests/tbs/tb0654.pp svneol=native#text/plain
 tests/tbs/tb205.pp svneol=native#text/plain
 tests/tbs/tb610.pp svneol=native#text/pascal
 tests/tbs/tb613.pp svneol=native#text/plain

+ 8 - 0
compiler/nobj.pas

@@ -511,6 +511,7 @@ implementation
         hclass : tobjectdef;
         hashedid : THashedIDString;
         srsym      : tsym;
+        overload: boolean;
       begin
         result:=nil;
         hashedid.id:=name;
@@ -523,9 +524,12 @@ implementation
                ((hclass=_class) or
                 is_visible_for_object(srsym,_class)) then
               begin
+                overload:=false;
                 for i:=0 to Tprocsym(srsym).ProcdefList.Count-1 do
                   begin
                     implprocdef:=tprocdef(tprocsym(srsym).ProcdefList[i]);
+                    if po_overload in implprocdef.procoptions then
+                      overload:=true;
                     if (implprocdef.procsym=tprocsym(srsym)) and
                        (compare_paras(proc.paras,implprocdef.paras,cp_all,[cpo_ignorehidden,cpo_ignoreuniv])>=te_equal) and
                        (compare_defs(proc.returndef,implprocdef.returndef,nothingn)>=te_equal) and
@@ -546,6 +550,10 @@ implementation
                         exit;
                       end;
                   end;
+                { like with normal procdef resolution (in htypechk), stop if
+                  we encounter a proc without the overload directive }
+                if not overload then
+                  exit;
               end;
             hclass:=hclass.childof;
           end;

+ 34 - 0
tests/tbf/tb0267.pp

@@ -0,0 +1,34 @@
+{ %fail }
+
+{$mode objfpc}{$h+}
+{$interfaces corba}
+
+type
+  tintf = interface
+    procedure test(l: longint);
+    procedure test(s: string);
+  end;
+
+  tp = class
+    procedure test(l: longint); virtual;
+    procedure test(s: string); virtual;
+  end;
+
+  tc = class(tp, tintf)
+    procedure test(l: longint); override;
+  end;
+
+procedure tp.test(l: longint);
+  begin
+  end;
+
+procedure tp.test(s: string);
+  begin
+  end;
+
+procedure tc.test(l: longint);
+  begin
+  end;
+
+begin
+end.

+ 34 - 0
tests/tbs/tb0654.pp

@@ -0,0 +1,34 @@
+{ %norun }
+
+{$mode objfpc}{$h+}
+{$interfaces corba}
+
+type
+  tintf = interface
+    procedure test(l: longint);
+    procedure test(s: string);
+  end;
+
+  tp = class
+    procedure test(l: longint); overload; virtual;
+    procedure test(s: string); overload; virtual;
+  end;
+
+  tc = class(tp, tintf)
+    procedure test(l: longint); override;
+  end;
+
+procedure tp.test(l: longint);
+  begin
+  end;
+
+procedure tp.test(s: string);
+  begin
+  end;
+
+procedure tc.test(l: longint);
+  begin
+  end;
+
+begin
+end.

+ 4 - 4
tests/webtbs/tw27349.pp

@@ -13,7 +13,7 @@ type
    type
 
     tmyintf = class(TInterfacedObject, iinterface)
-     function _AddRef : longint; stdcall;
+     function _AddRef : longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
     end;
 
   end;
@@ -23,17 +23,17 @@ type
    type
 
     tmyintf = class(TInterfacedObject, iinterface)
-     function _AddRef : longint; stdcall;
+     function _AddRef : longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
     end;
 
   end;
 
-function C.tmyintf._AddRef: longint; stdcall;
+function C.tmyintf._AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
 begin
  result := inherited _AddRef; // OK
 end;
 
-function R.tmyintf._AddRef: longint; stdcall;
+function R.tmyintf._AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
 begin
  result := inherited _AddRef; // FAIL
 end;