* separate the finally block that dezals with cleaning up temps and the

except block that deals with exceptions raised inside the constructor
    (including afterconstruction), so that afterconstruction is always
    called after all temps have been finalised (necessary because in case
    of tinterfacedobject it decreases the reference count of the instance
    without every freeing the instance, so if that is done before a temp
    that also holds a refernce is finalised, the temp may wrongly free
    the instance (mantis #16592, #16592)

git-svn-id: trunk@15583 -

.gitattributes

@@ -10529,6 +10529,7 @@ tests/webtbs/tw16366.pp svneol=native#text/plain
 tests/webtbs/tw16377.pp svneol=native#text/plain
 tests/webtbs/tw16402.pp svneol=native#text/plain
 tests/webtbs/tw1658.pp svneol=native#text/plain
+tests/webtbs/tw16592.pp svneol=native#text/plain
 tests/webtbs/tw16668.pp svneol=native#text/plain
 tests/webtbs/tw16700.pp svneol=native#text/plain
 tests/webtbs/tw16757.pp svneol=native#text/plain
@@ -10542,6 +10543,7 @@ tests/webtbs/tw16820.pp svneol=native#text/plain
 tests/webtbs/tw16861.pp svneol=native#text/plain
 tests/webtbs/tw16863.pp svneol=native#text/plain
 tests/webtbs/tw16874.pp svneol=native#text/plain
+tests/webtbs/tw16901.pp svneol=native#text/plain
 tests/webtbs/tw1696.pp svneol=native#text/plain
 tests/webtbs/tw1699.pp svneol=native#text/plain
 tests/webtbs/tw1709.pp svneol=native#text/plain

compiler/psub.pas

@@ -33,6 +33,7 @@ interface
     type
       tcgprocinfo = class(tprocinfo)
       private
+        procedure maybe_add_constructor_wrapper(var tocode: tnode);
         procedure add_entry_exit_code;
       public
         { code for the subroutine as tree }
@@ -446,9 +447,7 @@ implementation
 
     function generate_except_block:tnode;
       var
-        pd : tprocdef;
         newstatement : tstatementnode;
-        oldlocalswitches: tlocalswitches;
         { safecall handling }
         exceptobjnode,exceptaddrnode: ttempcreatenode;
         sym,exceptsym: tsym;
@@ -457,28 +456,8 @@ implementation
 
         { a constructor needs call destructor (if available) when it
           is not inherited }
-        if assigned(current_objectdef) and
-           (current_procinfo.procdef.proctypeoption=potype_constructor) then
-          begin
-            { Don't test self and the vmt here. See generate_bodyexit_block }
-            { why (JM)                                                      }
-            oldlocalswitches:=current_settings.localswitches;
-            current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range];
-            pd:=current_objectdef.find_destructor;
-            if assigned(pd) then
-              begin
-                { if vmt<>0 then call destructor }
-                addstatement(newstatement,cifnode.create(
-                    caddnode.create(unequaln,
-                        load_vmt_pointer_node,
-                        cnilnode.create),
-                    { cnf_create_failed -> don't call BeforeDestruction }
-                    ccallnode.create(nil,tprocsym(pd.procsym),pd.procsym.owner,load_self_node,[cnf_create_failed]),
-                    nil));
-              end;
-            current_settings.localswitches:=oldlocalswitches;
-          end
-        else
+        if not assigned(current_objectdef) or
+           (current_procinfo.procdef.proctypeoption<>potype_constructor) then
           begin
             { no constructor }
             { must be the return value finalized before reraising the exception? }
@@ -548,47 +527,6 @@ implementation
       end;
 
 
-    procedure maybe_add_afterconstruction(var tocode: tnode);
-      var
-        oldlocalswitches: tlocalswitches;
-        srsym: tsym;
-        newblock: tblocknode;
-        newstatement: tstatementnode;
-      begin
-        { maybe call AfterConstruction for classes }
-        if (current_procinfo.procdef.proctypeoption=potype_constructor) and
-           is_class(current_objectdef) then
-          begin
-            srsym:=search_class_member(current_objectdef,'AFTERCONSTRUCTION');
-            if assigned(srsym) and
-               (srsym.typ=procsym) then
-              begin
-                { Don't test self and the vmt here. See }
-                { generate_bodyexit_block why (JM)      }
-                oldlocalswitches:=current_settings.localswitches;
-                current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range];
-                newblock:=internalstatements(newstatement);
-                addstatement(newstatement,tocode);
-                { Self can be nil when fail is called }
-                { if self<>nil and vmt<>nil then afterconstruction }
-                addstatement(newstatement,cifnode.create(
-                    caddnode.create(andn,
-                        caddnode.create(unequaln,
-                            load_self_pointer_node,
-                            cnilnode.create),
-                        caddnode.create(unequaln,
-                            load_vmt_pointer_node,
-                            cnilnode.create)),
-                    ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
-                    nil));
-                tocode:=newblock;
-                current_settings.localswitches:=oldlocalswitches;
-              end
-            else
-              internalerror(200305106);
-          end;
-      end;
-
 {****************************************************************************
                                   TCGProcInfo
 ****************************************************************************}
@@ -632,12 +570,89 @@ implementation
       end;
 
 
+    procedure tcgprocinfo.maybe_add_constructor_wrapper(var tocode: tnode);
+      var
+        oldlocalswitches: tlocalswitches;
+        srsym: tsym;
+        afterconstructionblock,
+        exceptblock,
+        newblock: tblocknode;
+        newstatement: tstatementnode;
+        pd: tprocdef;
+      begin
+        if assigned(current_objectdef) and
+           (current_procinfo.procdef.proctypeoption=potype_constructor) then
+          begin
+            exceptblock:=nil;
+            { call AfterConstruction for classes }
+            if is_class(current_objectdef) then
+              begin
+                srsym:=search_class_member(current_objectdef,'AFTERCONSTRUCTION');
+                if assigned(srsym) and
+                   (srsym.typ=procsym) then
+                  begin
+                    current_filepos:=exitpos;
+                    afterconstructionblock:=internalstatements(newstatement);
+                    { first execute all constructor code. If no exception
+                      occurred then we will execute afterconstruction,
+                      otherwise we won't be (the exception will jump over us) }
+                    addstatement(newstatement,tocode);
+                    { if vmt<>nil then afterconstruction }
+                    addstatement(newstatement,cifnode.create(
+                      caddnode.create(unequaln,
+                          load_vmt_pointer_node,
+                          cnilnode.create),
+                        ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
+                        nil));
+                    tocode:=afterconstructionblock;
+                  end
+                else
+                  internalerror(200305106);
+              end;
+
+            { Generate the "fail" code for a constructor (destroy in case an
+              exception happened) }
+            { Don't test self and the vmt here. See generate_bodyexit_block }
+            { why (JM)                                                      }
+            oldlocalswitches:=current_settings.localswitches;
+            current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range];
+            pd:=current_objectdef.find_destructor;
+            { this will always be the case for classes, since tobject has
+              a destructor }
+            if assigned(pd) then
+              begin
+                current_filepos:=exitpos;
+                exceptblock:=internalstatements(newstatement);
+                { if vmt<>0 then call destructor }
+                addstatement(newstatement,cifnode.create(
+                    caddnode.create(unequaln,
+                        load_vmt_pointer_node,
+                        cnilnode.create),
+                    { cnf_create_failed -> don't call BeforeDestruction }
+                    ccallnode.create(nil,tprocsym(pd.procsym),pd.procsym.owner,load_self_node,[cnf_create_failed]),
+                    nil));
+                { re-raise the exception }
+                addstatement(newstatement,craisenode.create(nil,nil,nil));
+                current_filepos:=entrypos;
+                newblock:=internalstatements(newstatement);
+                addstatement(newstatement,ctryexceptnode.create(
+                  tocode,
+                  nil,
+                  exceptblock));
+                tocode:=newblock;
+              end;
+            current_settings.localswitches:=oldlocalswitches;
+          end;
+      end;
+
+
     procedure tcgprocinfo.add_entry_exit_code;
       var
         finalcode,
         bodyentrycode,
         bodyexitcode,
-        exceptcode   : tnode;
+        exceptcode,
+        wrappedbody: tnode;
         newblock     : tblocknode;
         codestatement,
         newstatement : tstatementnode;
@@ -656,7 +671,6 @@ implementation
         exitlabel_asmnode:=casmnode.create_get_position;
         final_asmnode:=casmnode.create_get_position;
         bodyexitcode:=generate_bodyexit_block;
-        maybe_add_afterconstruction(code);
 
         { Generate procedure by combining init+body+final,
           depending on the implicit finally we need to add
@@ -681,10 +695,17 @@ implementation
             addstatement(newstatement,init_asmnode);
             addstatement(newstatement,bodyentrycode);
             current_filepos:=entrypos;
-            addstatement(newstatement,ctryfinallynode.create_implicit(
+            wrappedbody:=ctryfinallynode.create_implicit(
                code,
                finalcode,
-               exceptcode));
+               exceptcode);
+            { afterconstruction must be called after final_asmnode, because it
+               has to execute after the temps have been finalised in case of a
+               refcounted class (afterconstruction decreases the refcount
+               without freeing the instance if the count becomes nil, while
+               the finalising of the temps can free the instance) }
+            maybe_add_constructor_wrapper(wrappedbody);
+            addstatement(newstatement,wrappedbody);
             addstatement(newstatement,exitlabel_asmnode);
             addstatement(newstatement,bodyexitcode);
             { set flag the implicit finally has been generated }
@@ -692,6 +713,7 @@ implementation
           end
         else
           begin
+            maybe_add_constructor_wrapper(code);
             addstatement(newstatement,loadpara_asmnode);
             addstatement(newstatement,stackcheck_asmnode);
             addstatement(newstatement,entry_asmnode);

tests/webtbs/tw16592.pp

@@ -0,0 +1,195 @@
+{ %opt=-g-h }
+
+program project1;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Classes, sysutils
+  { you can add units after this };
+
+type
+  { TInterfacedObj }
+
+  TInterfacedObj = class(TObject, IUnknown)
+    private
+      FOwner:TInterfacedObj;
+      FDestructorCalled:boolean;
+
+      function GetInterface(const iid: tguid; out obj): longint;
+      procedure Log(const Str:string);
+    protected
+      FRefCount : longint;
+    public
+      function QueryInterface(const iid : tguid;out obj) : longint;stdcall;
+      function _AddRef : longint;stdcall;
+      function _Release : longint;stdcall;
+
+      constructor Create;
+
+      procedure AfterConstruction;override;
+      procedure BeforeDestruction;override;
+      class function NewInstance : TObject;override;
+
+      property Owner:TInterfacedObj read FOwner write FOwner;
+  end;
+
+
+  IIntf1 = interface
+    ['{EFB94FA8-4F38-4E44-8D12-74A84D07A78C}']
+  end;
+
+  IIntf2 = interface
+   ['{EBC4A858-7BAC-4310-8426-E52B449D022A}']
+    procedure Print;
+    procedure SetI(const S:string);
+  end;
+
+  TClass1 = class(TInterfacedObj, IIntf1)
+
+  end;
+
+  { TClass2 }
+
+  TClass2 = class(TInterfacedObj, IIntf2)
+    i:string;
+    procedure Print;
+    procedure SetI(const S:string);
+  end;
+
+  TClass3 = class(TClass1, IIntf2)
+    private
+      FIntf2:IIntf2;
+      property Intf2Prop:IIntf2 read FIntf2 implements IIntf2;
+    public
+      constructor Create;
+  end;
+
+{ TClass2 }
+
+procedure TClass2.Print;
+begin
+  WriteLn('Print ', i);
+end;
+
+procedure TClass2.SetI(const S: string);
+begin
+  i:=S;
+end;
+
+  { TInterfacedObj }
+
+  const Err = HResult($80004002);
+  function TInterfacedObj.GetInterface(const iid: tguid; out obj): longint;
+  begin
+    if inherited GetInterface(IID, Obj) then
+      Result:=0
+    else
+      Result:=Err;
+  end;
+
+  procedure TInterfacedObj.Log(const Str: string);
+  begin
+    WriteLn(Format('%s Obj=$%P class=%s RefCount=%d', [Str, Pointer(Self), ClassName, FRefCount]));
+  end;
+
+function TInterfacedObj.QueryInterface(const iid: tguid; out obj): longint;stdcall;
+  begin
+    Result:=GetInterface(iid, obj);
+
+    //try to find interface in Owner
+    if (FOwner <> nil) and (Result = Err) then
+      Result:=FOwner.QueryInterface(iid, obj);
+  end;
+
+  function TInterfacedObj._AddRef : longint;stdcall;[public,alias:'TInterfacedObj_AddRef'];
+  begin
+    if not FDestructorCalled then
+      begin
+        _addref:=interlockedincrement(frefcount);
+        Log('AddRef');
+
+        if FOwner <> nil then
+           FOwner._AddRef;
+      end;
+  end;
+
+  function TInterfacedObj._Release : longint;stdcall;
+  begin
+    if FDestructorCalled then Exit;
+
+    _Release:=interlockeddecrement(frefcount);
+    Log('Release');
+    if _Release=0 then
+      begin
+        FDestructorCalled:=True;
+
+        Log('Destroy');
+        self.destroy;
+      end
+      else
+      if FOwner <> nil then
+        FOwner._Release;
+  end;
+
+  procedure TInterfacedObj.AfterConstruction;
+  begin
+     { we need to fix the refcount we forced in newinstance }
+     { further, it must be done in a thread safe way        }
+     //declocked(frefcount);
+    interlockeddecrement(frefcount);
+    Log('AfterConstruction');
+  end;
+
+  procedure TInterfacedObj.BeforeDestruction;
+  begin
+     Log('BeforeDestruction');
+     if frefcount<>0 then
+       raise Exception.Create('Cannot free object still referenced.');
+  end;
+
+  class function TInterfacedObj.NewInstance : TObject;
+  begin
+     NewInstance:=inherited NewInstance;
+     if NewInstance<>nil then
+       TInterfacedObj(NewInstance).frefcount:=1;
+  end;
+
+  constructor TInterfacedObj.Create;
+  begin
+    FDestructorCalled:=false;
+    inherited Create;
+    FOwner:=nil;
+  end;
+
+
+{ TClass2 }
+
+constructor TClass3.Create;
+var O:TClass2;
+begin
+  inherited Create;
+  O:=TClass2.Create;
+  FIntf2:=O;
+  O.Owner:=Self;
+
+  FIntf2.SetI('AAA'); //this line is crucial for bug reproducing
+end;
+
+var O:TClass3;
+    I1:IIntf1;
+    I2:IIntf2;
+begin
+  HaltOnNotReleased := true;
+  O:=TClass3.Create;
+  I1:=O;
+
+  //at this moment O object is already freed in rev.15156+ !!!
+  I2:=I1 as IIntf2;
+  I2.Print;
+  Writeln('ok');
+end.
+

tests/webtbs/tw16901.pp

@@ -0,0 +1,28 @@
+{ %opt=-g-h }
+
+program project1;
+{$mode objfpc}{$H+}
+uses
+  SysUtils;
+
+type
+  TClassA = class(TInterfacedObject,IInterface)
+  public
+    constructor Create();
+  end;
+
+constructor TClassA.Create(); 
+var
+  x : IInterface;
+begin
+  x := Self;
+end;
+
+var
+  y : IInterface;
+begin
+  HaltOnNotReleased := true;
+  y := TClassA.Create();
+end.
+
+