Merged revisions 11595,11599,11619,11621-11622,11628,11662 via svnmerge from

svn+ssh://[email protected]/FPC/svn/fpc/trunk

........
  r11595 | jonas | 2008-08-16 22:08:25 +0200 (Sat, 16 Aug 2008) | 6 lines
  
    * 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)
........
  r11599 | jonas | 2008-08-17 14:38:41 +0200 (Sun, 17 Aug 2008) | 5 lines
  
    * also free memory when a destructor is called without an explicit
      instance reference (mantis 11896)
    * fixed double destructor call in tests/test/cg/tcalcla1.pp which
      caused an error after this change
........
  r11662 | jonas | 2008-08-29 09:42:21 +0200 (Fri, 29 Aug 2008) | 2 lines
  
    * fixed oo_is_forward flag (from old patch by Dave Strodt)
........

git-svn-id: branches/fixes_2_2@12146 -

.gitattributes

@@ -7703,6 +7703,7 @@ tests/webtbf/tw10890a.pp svneol=native#text/plain
 tests/webtbf/tw10998a.pp svneol=native#text/plain
 tests/webtbf/tw11254a.pp svneol=native#text/plain
 tests/webtbf/tw1157a.pp svneol=native#text/plain
+tests/webtbf/tw11862a.pp svneol=native#text/plain
 tests/webtbf/tw11970.pp svneol=native#text/plain
 tests/webtbf/tw12365a.cfg svneol=native#text/plain
 tests/webtbf/tw12365a.pp svneol=native#text/plain
@@ -8112,6 +8113,8 @@ tests/webtbs/tw11786.pp svneol=native#text/plain
 tests/webtbs/tw1181.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/tw11896.pp svneol=native#text/plain
 tests/webtbs/tw1203.pp svneol=native#text/plain
 tests/webtbs/tw1204.pp svneol=native#text/plain
 tests/webtbs/tw12051.pp svneol=native#text/plain

compiler/ncal.pas

@@ -1697,14 +1697,21 @@ implementation
                 without specifying self explicit }
               if (cnf_member_call in callnodeflags) then
                 begin
-                  { destructor: don't release instance, vmt=0
-                    constructor:
-                      if called from a constructor in the same class then
+                  { destructor (in the same class, since cnf_member_call):
+                    if not called from a destructor then
+                      call beforedestruction and release instance, vmt=1
+                    else
+                      don't release instance, vmt=0
+                    constructor (in the same class, since cnf_member_call):
+                      if called from a constructor then
                         don't call afterconstruction, vmt=0
                       else
                         call afterconstrution, vmt=1 }
                   if (procdefinition.proctypeoption=potype_destructor) then
-                    vmttree:=cpointerconstnode.create(0,voidpointertype)
+                    if (current_procinfo.procdef.proctypeoption<>potype_constructor) then
+                      vmttree:=cpointerconstnode.create(1,voidpointertype)
+                    else
+                      vmttree:=cpointerconstnode.create(0,voidpointertype)
                   else if (current_procinfo.procdef.proctypeoption=potype_constructor) and
                           (procdefinition.proctypeoption=potype_constructor) then
                     vmttree:=cpointerconstnode.create(0,voidpointertype)
@@ -1723,7 +1730,7 @@ implementation
                     if called from a constructor in the same class using self.create then
                       don't call afterconstruction, vmt=0
                     else
-                      call afterconstrution, vmt=1 }
+                      call afterconstruction, vmt=1 }
                 if (procdefinition.proctypeoption=potype_destructor) then
                   if not(cnf_create_failed in callnodeflags) then
                     vmttree:=cpointerconstnode.create(1,voidpointertype)

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

@@ -4267,22 +4267,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;
 
 

compiler/utils/ppudump.pp

@@ -1305,7 +1305,7 @@ type
 const
   symopts=14;
   symopt : array[1..symopts] of tsymopt=(
-     (mask:oo_has_virtual;        str:'IsForward'),
+     (mask:oo_is_forward;         str:'IsForward'),
      (mask:oo_has_virtual;        str:'HasVirtual'),
      (mask:oo_has_private;        str:'HasPrivate'),
      (mask:oo_has_protected;      str:'HasProtected'),

tests/test/cg/tcalcla1.pp

@@ -2175,7 +2175,9 @@ var
       failed := true;
     if global_bigstring <> RESULT_BIGSTRING then
       failed := true;
+{ already called by method_virtual_call_destructor above
     vmtclass.destructor_params_done;
+}
 
     if failed then
       fail
@@ -3650,7 +3652,9 @@ procedure testwith;
       failed := true;
     if global_bigstring <> RESULT_BIGSTRING then
       failed := true;
+{ already called by method_virtual_call_destructor above
     destructor_params_done;
+}
 
     if failed then
       fail

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.

tests/webtbs/tw11896.pp

@@ -0,0 +1,51 @@
+program destroytest;
+
+{$mode delphi}
+
+type
+  TTest = class(TObject)
+    a: array[0..32767] of Integer;
+    procedure x;
+    procedure y;
+    procedure beforedestruction;override;
+  end;
+
+var
+  testobj: TTest;
+  destroyed: boolean;
+
+procedure TTest.beforedestruction;
+begin
+  destroyed:=true;
+  inherited beforedestruction;
+end;
+
+procedure TTest.x;
+begin
+  Destroy;
+end;
+
+procedure TTest.y;
+begin
+  Self.Destroy;
+end;
+
+function GetUsedMemory: Integer;
+begin
+  Result := GetHeapStatus.TotalAllocated;
+end;
+
+begin
+  testobj := TTest.create;
+  destroyed:=false;
+  testobj.x;
+  if not destroyed then
+    halt(1);
+
+  destroyed:=false;
+  testobj := TTest.create;
+  testobj.y;
+  if not destroyed then
+    halt(2);
+end.
+