* create a new vmt entry also if return type differs

  * search all parent classes for matching interface implementations

git-svn-id: trunk@8138 -

.gitattributes

@@ -7285,7 +7285,6 @@ tests/webtbf/tw3116.pp svneol=native#text/plain
 tests/webtbf/tw3126.pp svneol=native#text/plain
 tests/webtbf/tw3145.pp svneol=native#text/plain
 tests/webtbf/tw3183.pp svneol=native#text/plain
-tests/webtbf/tw3183b.pp svneol=native#text/plain
 tests/webtbf/tw3186.pp svneol=native#text/plain
 tests/webtbf/tw3218.pp svneol=native#text/plain
 tests/webtbf/tw3241.pp svneol=native#text/plain
@@ -8353,6 +8352,8 @@ tests/webtbs/tw9209.pp svneol=native#text/plain
 tests/webtbs/tw9221.pp svneol=native#text/plain
 tests/webtbs/tw9261.pp svneol=native#text/x-pascal
 tests/webtbs/tw9278.pp svneol=native#text/plain
+tests/webtbs/tw9306a.pp -text
+tests/webtbs/tw9306b.pp -text
 tests/webtbs/tw9309.pp -text
 tests/webtbs/ub1873.pp svneol=native#text/plain
 tests/webtbs/ub1883.pp svneol=native#text/plain

compiler/nobj.pas

@@ -128,7 +128,7 @@ implementation
     uses
        SysUtils,
        globals,verbose,systems,
-       symtable,symconst,symtype,defcmp,
+       symbase,symtable,symconst,symtype,defcmp,
        dbgbase,
        ncgrtti
        ;
@@ -308,8 +308,9 @@ implementation
                               MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
                           end;
                       end
-                    { same parameters }
-                    else if (compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal) then
+                    { same parameter and return types (parameter specifiers will be checked below) }
+                    else if (compare_paras(procdefcoll^.data.paras,pd.paras,cp_none,[])>=te_equal) and
+                            compatible_childmethod_resultdef(procdefcoll^.data.returndef,pd.returndef) then
                       begin
                         { overload is inherited }
                         if (po_overload in procdefcoll^.data.procoptions) then
@@ -324,9 +325,10 @@ implementation
                             include(pd.procoptions,po_hascallingconvention);
                           end;
 
-                        { the flags have to match except abstract and override }
-                        { only if both are virtual !!  }
-                        if (procdefcoll^.data.proccalloption<>pd.proccalloption) or
+                        { All parameter specifiers and some procedure the flags have to match
+                          except abstract and override }
+                        if (compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])<te_equal) or
+                           (procdefcoll^.data.proccalloption<>pd.proccalloption) or
                            (procdefcoll^.data.proctypeoption<>pd.proctypeoption) or
                            ((procdefcoll^.data.procoptions*po_comp)<>(pd.procoptions*po_comp)) then
                            begin
@@ -334,19 +336,6 @@ implementation
                              tprocsym(procdefcoll^.data.procsym).write_parameter_lists(pd);
                            end;
 
-                        { error, if the return types aren't equal }
-                        if not compatible_childmethod_resultdef(procdefcoll^.data.returndef,pd.returndef) then
-                          begin
-                            if not((m_delphi in current_settings.modeswitches) and
-                                   is_interface(_class)) then
-                              Message2(parser_e_overridden_methods_not_same_ret,pd.fullprocname(false),
-                                       procdefcoll^.data.fullprocname(false))
-                            else
-                              { Delphi allows changing the result type of interface methods from anything to
-                                anything (JM) }
-                              Message2(parser_w_overridden_methods_not_same_ret,pd.fullprocname(false),
-                                       procdefcoll^.data.fullprocname(false));
-                          end;
                         { check if the method to override is visible, check is only needed
                           for the current parsed class. Parent classes are already validated and
                           need to include all virtual methods including the ones not visible in the
@@ -451,36 +440,37 @@ implementation
         po_comp = [po_classmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint,
                    po_exports,po_varargs,po_explicitparaloc,po_nostackframe];
       var
-        sym: tsym;
         implprocdef : Tprocdef;
         i: cardinal;
+        hclass : tobjectdef;
+        hashedid : THashedIDString;
+        srsym      : tsym;
       begin
         result:=nil;
-
-        sym:=tsym(search_class_member(_class,name));
-        if assigned(sym) and
-           (sym.typ=procsym) then
+        hashedid.id:=name;
+        hclass:=_class;
+        while assigned(hclass) do
           begin
-            { when the definition has overload directive set, we search for
-              overloaded definitions in the class, this only needs to be done once
-              for class entries as the tree keeps always the same }
-            if (not tprocsym(sym).overloadchecked) and
-               (po_overload in tprocdef(tprocsym(sym).ProcdefList[0]).procoptions) and
-               (tprocsym(sym).owner.symtabletype=ObjectSymtable) then
-             search_class_overloads(tprocsym(sym));
-
-            for i:=0 to Tprocsym(sym).ProcdefList.Count-1 do
+            srsym:=tsym(hclass.symtable.FindWithHash(hashedid));
+            if assigned(srsym) and
+               (srsym.typ=procsym) then
               begin
-                implprocdef:=tprocdef(Tprocsym(sym).ProcdefList[i]);
-                if (compare_paras(proc.paras,implprocdef.paras,cp_none,[])>=te_equal) and
-                   (proc.proccalloption=implprocdef.proccalloption) and
-                   (proc.proctypeoption=implprocdef.proctypeoption) and
-                   ((proc.procoptions*po_comp)=((implprocdef.procoptions+[po_virtualmethod])*po_comp)) then
+                for i:=0 to Tprocsym(srsym).ProcdefList.Count-1 do
                   begin
-                    result:=implprocdef;
-                    exit;
+                    implprocdef:=tprocdef(tprocsym(srsym).ProcdefList[i]);
+                    if (implprocdef.procsym=tprocsym(srsym)) and
+                       (compare_paras(proc.paras,implprocdef.paras,cp_all,[cpo_ignorehidden,cpo_comparedefaultvalue])>=te_equal) and
+                       compatible_childmethod_resultdef(proc.returndef,implprocdef.returndef) and
+                       (proc.proccalloption=implprocdef.proccalloption) and
+                       (proc.proctypeoption=implprocdef.proctypeoption) and
+                       ((proc.procoptions*po_comp)=((implprocdef.procoptions+[po_virtualmethod])*po_comp)) then
+                      begin
+                        result:=implprocdef;
+                        exit;
+                      end;
                   end;
               end;
+            hclass:=hclass.childof;
           end;
       end;
 
@@ -513,13 +503,7 @@ implementation
                   implprocdef:=intf_search_procdef_by_name(tprocdef(def),tprocdef(def).procsym.name);
                 { Add procdef to the implemented interface }
                 if assigned(implprocdef) then
-                  begin
-                    if (compare_paras(tprocdef(def).paras,implprocdef.paras,cp_all,[cpo_ignorehidden,cpo_comparedefaultvalue])<te_equal) or
-                       not compatible_childmethod_resultdef(tprocdef(def).returndef,implprocdef.returndef) then
-                      MessagePos1(tprocdef(implprocdef).fileinfo,parser_e_header_dont_match_forward,
-                                  tprocdef(def).fullprocname(false));
-                    ImplIntf.AddImplProc(implprocdef)
-                  end
+                  ImplIntf.AddImplProc(implprocdef)
                 else
                   if ImplIntf.IType = etStandard then
                     Message1(sym_e_no_matching_implementation_found,tprocdef(def).fullprocname(false));

tests/webtbf/tw3183b.pp

@@ -1,14 +0,0 @@
-{ %fail }
-{$mode objfpc}
-
-type
-  ta = interface
-    function a: longint;
-  end;
-
-  tb = interface(ta)
-    function a: ansistring;
-  end;
-
-begin
-end.

tests/webtbs/tw9306a.pp

@@ -0,0 +1,63 @@
+{$mode objfpc}
+
+type
+  IIntf = interface
+    function Foo(const S: string): string;
+  end;
+
+  IIntf2 = interface(IIntf)
+    function Foo(const S: string): Integer;
+  end;
+
+  TIntf = class(TInterfacedObject, IIntf)
+  protected
+    { IIntf }
+    function Foo(const S: string): string;
+  end;
+
+  TIntf2 = class(TIntf, IIntf2)
+  public
+    { IIntf2 }
+    function Foo(const S: string): Integer; overload;
+  end;
+
+var
+  erridx : longint;
+
+{ TIntf }
+
+function TIntf.Foo(const S: string): string;
+begin
+  writeln('TIntf.Foo: ',S);
+  if erridx=0 then
+    erridx:=1;
+  result:=S;
+end;
+
+{ TIntf2 }
+
+function TIntf2.Foo(const S: string): Integer;
+begin
+  writeln('TIntf2.Foo: ',S);
+  if erridx=1 then
+    erridx:=2;
+  result:=0;
+end;
+
+var
+  i1 : IIntf;
+  i2 : IIntf2;
+begin
+  erridx:=0;
+
+  i1:=TIntf2.Create;
+  i1.Foo('1234');
+
+  i2:=TIntf2.Create;
+  i2.Foo('1234');
+  if erridx<>2 then
+    begin
+      writeln('Error');
+      halt(1);
+    end;
+end.

tests/webtbs/tw9306b.pp

@@ -0,0 +1,63 @@
+{$mode delphi}
+
+type
+  IIntf = interface
+    function Foo(const S: string): string;
+  end;
+
+  IIntf2 = interface(IIntf)
+    function Foo(const S: string): Integer;
+  end;
+
+  TIntf = class(TInterfacedObject, IIntf)
+  protected
+    { IIntf }
+    function Foo(const S: string): string;
+  end;
+
+  TIntf2 = class(TIntf, IIntf2)
+  public
+    { IIntf2 }
+    function Foo(const S: string): Integer; overload;
+  end;
+
+var
+  erridx : longint;
+
+{ TIntf }
+
+function TIntf.Foo(const S: string): string;
+begin
+  writeln('TIntf.Foo: ',S);
+  if erridx=0 then
+    erridx:=1;
+  result:=S;
+end;
+
+{ TIntf2 }
+
+function TIntf2.Foo(const S: string): Integer;
+begin
+  writeln('TIntf2.Foo: ',S);
+  if erridx=1 then
+    erridx:=2;
+  result:=0;
+end;
+
+var
+  i1 : IIntf;
+  i2 : IIntf2;
+begin
+  erridx:=0;
+
+  i1:=TIntf2.Create;
+  i1.Foo('1234');
+
+  i2:=TIntf2.Create;
+  i2.Foo('1234');
+  if erridx<>2 then
+    begin
+      writeln('Error');
+      halt(1);
+    end;
+end.