* call beforedestruction if an exception happens in afterconstruction

    (mantis #30570)

git-svn-id: trunk@34453 -

.gitattributes

@@ -15213,6 +15213,7 @@ tests/webtbs/tw30443.pp svneol=native#text/plain
 tests/webtbs/tw3045.pp svneol=native#text/plain
 tests/webtbs/tw3048.pp svneol=native#text/plain
 tests/webtbs/tw30522.pp svneol=native#text/plain
+tests/webtbs/tw30570.pp svneol=native#text/plain
 tests/webtbs/tw30572.pp svneol=native#text/plain
 tests/webtbs/tw3063.pp svneol=native#text/plain
 tests/webtbs/tw3064.pp svneol=native#text/plain

compiler/ncal.pas

@@ -1469,6 +1469,9 @@ implementation
  ****************************************************************************}
 
     constructor tcallnode.create(l:tnode;v : tprocsym;st : TSymtable; mp: tnode; callflags:tcallnodeflags;sc:tspecializationcontext);
+      var
+        srsym: tsym;
+        srsymtable: tsymtable;
       begin
          inherited create(calln,l,nil);
          spezcontext:=sc;
@@ -1487,10 +1490,16 @@ implementation
            begin
             { only needed when calling a destructor from an exception block in a
               contructor of a TP-style object }
-            if is_object(current_structdef) and
-               (current_procinfo.procdef.proctypeoption=potype_constructor) and
+            if (current_procinfo.procdef.proctypeoption=potype_constructor) and
                (cnf_create_failed in callflags) then
-              call_vmt_node:=load_vmt_pointer_node;
+              if is_object(current_structdef) then
+                call_vmt_node:=load_vmt_pointer_node
+              else if is_class(current_structdef) then
+                begin
+                  if not searchsym(copy(internaltypeprefixName[itp_vmt_afterconstruction_local],2,255),srsym,srsymtable) then
+                    internalerror(2016090801);
+                  call_vmt_node:=cloadnode.create(srsym,srsymtable);
+                end;
            end;
       end;
 
@@ -2798,7 +2807,8 @@ implementation
             { normal call to method like cl1.proc }
               begin
                 { destructor:
-                     if not called from exception block in constructor
+                     if not(called from exception block in constructor) or
+                        (called from afterconstruction)
                        call beforedestruction and release instance, vmt=1
                      else
                        don't call beforedestruction and release instance, vmt=-1
@@ -2808,7 +2818,10 @@ implementation
                     else
                       call afterconstruction, vmt=1 }
                 if (procdefinition.proctypeoption=potype_destructor) then
-                  if not(cnf_create_failed in callnodeflags) then
+                  if (cnf_create_failed in callnodeflags) and
+                     is_class(methodpointer.resultdef) then
+                    vmttree:=call_vmt_node.getcopy
+                  else if not(cnf_create_failed in callnodeflags) then
                     vmttree:=cpointerconstnode.create(1,voidpointertype)
                   else
                     vmttree:=cpointerconstnode.create(TConstPtrUInt(-1),voidpointertype)

compiler/psub.pas

@@ -724,6 +724,7 @@ implementation
         newblock: tblocknode;
         newstatement: tstatementnode;
         pd: tprocdef;
+        constructionsuccessful: tlocalvarsym;
       begin
         if assigned(procdef.struct) and
            (procdef.proctypeoption=potype_constructor) then
@@ -737,8 +738,11 @@ implementation
             current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range];
 
             { call AfterConstruction for classes }
+            constructionsuccessful:=nil;
             if is_class(procdef.struct) then
               begin
+                constructionsuccessful:=clocalvarsym.create(internaltypeprefixName[itp_vmt_afterconstruction_local],vs_value,ptrsinttype,[],false);
+                procdef.localst.insert(constructionsuccessful,false);
                 srsym:=search_struct_member(procdef.struct,'AFTERCONSTRUCTION');
                 if not assigned(srsym) or
                    (srsym.typ<>procsym) then
@@ -746,6 +750,14 @@ implementation
 
                 current_filepos:=entrypos;
                 constructionblock:=internalstatements(newstatement);
+                { initialise constructionsuccessful with -1, indicating that
+                  the construction was not successful and hence
+                  beforedestruction should not be called if a destructor is
+                  called from the constructor }
+                addstatement(newstatement,cassignmentnode.create(
+                  cloadnode.create(constructionsuccessful,procdef.localst),
+                  genintconstnode(-1))
+                );
                 { first execute all constructor code. If no exception
                   occurred then we will execute afterconstruction,
                   otherwise we won't (the exception will jump over us) }
@@ -763,6 +775,12 @@ implementation
                     final_used:=true;
                   end;
 
+                { construction successful -> beforedestruction should be called
+                  if an exception happens now }
+                addstatement(newstatement,cassignmentnode.create(
+                  cloadnode.create(constructionsuccessful,procdef.localst),
+                  genintconstnode(1))
+                );
                 { Self can be nil when fail is called }
                 { if self<>nil and vmt<>nil then afterconstruction }
                 addstatement(newstatement,cifnode.create(

compiler/symconst.pas

@@ -690,6 +690,7 @@ type
     itp_vmt_intern_msgint_table,
     itp_vmt_intern_tmethodnamerec,
     itp_vmt_intern_tmethodnametable,
+    itp_vmt_afterconstruction_local,
     itp_rttidef,
     itp_rtti_header,
     itp_rtti_prop,
@@ -830,6 +831,7 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has
        '$vmt_intern_msgint_table$',
        '$vmt_intern_tmethodnamerec$',
        '$vmt_intern_tmethodnametable$',
+       '$vmt_afterconstruction_local',
        '$rttidef$',
        '$rtti_header$',
        '$rtti_prop$',

tests/webtbs/tw30570.pp

@@ -0,0 +1,98 @@
+program project1;
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$IFDEF MSWINDOWS}
+  {$APPTYPE CONSOLE}
+{$ENDIF}
+
+{$r+}
+
+uses SysUtils;
+
+type
+  TSomeClass = class
+  public
+    procedure LoadSomething;
+  end;
+
+  TA = class
+  private
+    FSomeObject: TSomeClass;
+  public
+    constructor Create; virtual;
+    destructor Destroy; override;
+    procedure AfterConstruction; override;
+    procedure BeforeDestruction; override;
+    property SomeObject: TSomeClass read FSomeObject;
+  end;
+
+var
+  i: longint;
+  order: array[1..4] of longint;
+
+procedure TSomeClass.LoadSomething;
+begin
+  raise Exception.Create('An exception loading something');
+end;
+
+constructor TA.Create;
+begin
+  order[i]:=1;
+  inc(i);
+  WriteLn(1);
+  inherited Create;
+end;
+
+destructor TA.Destroy;
+begin
+  order[i]:=2;
+  inc(i);
+  WriteLn(2);
+  inherited Destroy;
+end;
+
+procedure TA.AfterConstruction;
+begin
+  order[i]:=3;
+  inc(i);
+  WriteLn(3);
+  FSomeObject := TSomeClass.Create;
+  FSomeObject.LoadSomething;
+end;
+
+procedure TA.BeforeDestruction;
+begin
+  order[i]:=4;
+  inc(i);
+  WriteLn(4);
+  FSomeObject.Free;
+end;
+
+var
+  VA: TA;
+  ok: boolean;
+begin
+  i:=1;
+  ok:=false;
+  try
+    VA := TA.Create;
+  except
+    if order[1]<>1 then
+      halt(1);
+    if order[2]<>3 then
+      halt(2);
+    if order[3]<>4 then
+      halt(3);
+    if order[4]<>2 then
+      halt(4);
+    if i<>5 then
+      halt(5);
+    if assigned(va) then
+      halt(6);
+    ok:=true;
+  end;
+  if not ok then
+    halt(7);
+end.