* method definitions in "child" interfaces also hide those in "parent"

interfaces, even if they only differ in resulttype (mantis #11862)
  * fixing this required that multiple entries for the same method in a
    interface vmt are all written out (change in
    ImplementedInterface.AddImplProc)

git-svn-id: trunk@11595 -

.gitattributes

@@ -8105,6 +8105,7 @@ tests/webtbf/tw1157a.pp svneol=native#text/plain
 tests/webtbf/tw11619b.pp svneol=native#text/plain
 tests/webtbf/tw11632.pp svneol=native#text/plain
 tests/webtbf/tw11848a.pp svneol=native#text/plain
+tests/webtbf/tw11862a.pp svneol=native#text/plain
 tests/webtbf/tw1238.pp svneol=native#text/plain
 tests/webtbf/tw1251a.pp svneol=native#text/plain
 tests/webtbf/tw1270.pp svneol=native#text/plain
@@ -8543,6 +8544,7 @@ tests/webtbs/tw1181.pp svneol=native#text/plain
 tests/webtbs/tw11848.pp svneol=native#text/plain
 tests/webtbs/tw11852.pp svneol=native#text/plain
 tests/webtbs/tw11861.pp svneol=native#text/plain
+tests/webtbs/tw11862.pp svneol=native#text/plain
 tests/webtbs/tw1203.pp svneol=native#text/plain
 tests/webtbs/tw1204.pp svneol=native#text/plain
 tests/webtbs/tw1207.pp svneol=native#text/plain

compiler/nobj.pas

@@ -128,6 +128,7 @@ implementation
     uses
        SysUtils,
        globals,verbose,systems,
+       node,
        symbase,symtable,symconst,symtype,defcmp,
        dbgbase,
        ncgrtti
@@ -292,7 +293,7 @@ implementation
                         (po_virtualmethod in procdefcoll^.data.procoptions) then
                   begin
                     { new one has not override }
-                    if is_class(_class) and
+                    if is_class_or_interface(_class) and
                        not(po_overridingmethod in pd.procoptions) then
                       begin
                         { we start a new virtual tree, hide the old }
@@ -464,7 +465,7 @@ implementation
                     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
+                       (compare_defs(proc.returndef,implprocdef.returndef,nothingn)>=te_equal) and
                        (proc.proccalloption=implprocdef.proccalloption) and
                        (proc.proctypeoption=implprocdef.proctypeoption) and
                        ((proc.procoptions*po_comp)=((implprocdef.procoptions+[po_virtualmethod])*po_comp)) then

compiler/symdef.pas

@@ -4263,22 +4263,13 @@ implementation
 
 
     procedure TImplementedInterface.AddImplProc(pd:tprocdef);
-      var
-        i : longint;
-        found : boolean;
       begin
         if not assigned(procdefs) then
           procdefs:=TFPObjectList.Create(false);
-        { No duplicate entries of the same procdef }
-        found:=false;
-        for i:=0 to procdefs.count-1 do
-          if tprocdef(procdefs[i])=pd then
-            begin
-              found:=true;
-              break;
-            end;
-        if not found then
-          procdefs.Add(pd);
+        { duplicate entries must be stored, because multiple }
+        { interfaces can declare methods with the same name  }
+        { and all of these get their own VMT entry           }
+        procdefs.Add(pd);
       end;
 
 

tests/webtbf/tw11862a.pp

@@ -0,0 +1,57 @@
+{ %fail }
+
+program bug9;
+
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+
+
+type
+  ITest = interface(IInterface)
+    ['{FE6B16A6-A898-4B09-A46E-0AAC5E0A4E14}']
+    function Parent: ITest;
+    function GetChild: ITest;
+  end;
+
+  ITestEx = interface(ITest)
+    ['{82449E91-76BE-4F4A-B873-1865042D5CAF}']
+  end;
+
+  TTest = class(TInterfacedObject, ITest)
+    function ITest.Parent = ParentEx;
+    { ITestEx }
+    function ParentEx: ITestEx;
+    function GetChild: ITest;
+    procedure RemoveChild;
+  end;
+    { ITest }
+
+    { ITestEx }
+
+function TTest.ParentEx: ITest;
+begin;
+Result := nil
+end;
+
+
+
+function TTest.GetChild: ITest;
+begin;
+WriteLn('TTest.GetChild');
+Result := nil
+end;
+
+procedure TTest.RemoveChild;
+begin;
+WriteLn('TTest.RemoveChild');
+end;
+
+
+var E: ITest;
+begin
+  E := TTest.Create;
+  WriteLn('Calling GetChild');
+  E.GetChild();
+  WriteLn('Stop');
+end.

tests/webtbs/tw11862.pp

@@ -0,0 +1,86 @@
+program bug9;
+
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+
+
+type
+  ttesttype = (testgetchild,testparent,testparentex);
+
+  ITest = interface(IInterface)
+    ['{FE6B16A6-A898-4B09-A46E-0AAC5E0A4E14}']
+    function Parent: ITest;
+  end;
+
+  ITestEx = interface(ITest)
+    ['{82449E91-76BE-4F4A-B873-1865042D5CAF}']
+    function Parent: ITestEx;
+    function GetChild: ITestEx;
+    procedure RemoveChild;
+  end;
+
+  TTest = class(TInterfacedObject, ITestEx)
+    function ITestEx.Parent = ParentEx;
+    { ITest }
+    function Parent: ITest;
+    { ITestEx }
+    function ParentEx: ITestEx;
+    function GetChild: ITestEx;
+    procedure RemoveChild;
+  end;
+    { ITest }
+var
+  test: ttesttype;
+
+function TTest.Parent: ITest;
+begin;
+writeln('ttest.parent');
+Result := nil;
+if (test<>testparent) then
+  halt(1);
+end;
+
+
+
+    { ITestEx }
+
+function TTest.ParentEx: ITestEx;
+begin;
+writeln('ttest.parentex');
+Result := nil;
+if (test<>testparentex) then
+  halt(1);
+end;
+
+
+
+function TTest.GetChild: ITestEx;
+begin;
+WriteLn('TTest.GetChild');
+Result := nil;
+if (test<>testgetchild) then
+  halt(1);
+end;
+
+procedure TTest.RemoveChild;
+begin;
+WriteLn('TTest.RemoveChild');
+halt(1);
+end;
+
+
+var E: ITestEx;
+    e2: itest;
+begin
+  E := TTest.Create;
+  WriteLn('Calling GetChild');
+  test:=testgetchild;
+  E.GetChild();
+  test:=testparentex;
+  e.parent;
+  test:=testparent;
+  e2:=e;
+  e2.parent;
+  WriteLn('Stop');
+end.