* don't call afterconstruction/beforedestruction in case an exception

is raised in a constructor (mantis 8222)

git-svn-id: trunk@6202 -

.gitattributes

@@ -8006,6 +8006,9 @@ tests/webtbs/tw8156.pp svneol=native#text/plain
 tests/webtbs/tw8171.pp svneol=native#text/plain
 tests/webtbs/tw8172.pp svneol=native#text/plain
 tests/webtbs/tw8183.pp svneol=native#text/plain
+tests/webtbs/tw8222.pp svneol=native#text/plain
+tests/webtbs/tw8222a.pp svneol=native#text/plain
+tests/webtbs/tw8222b.pp svneol=native#text/plain
 tests/webtbs/ub1873.pp svneol=native#text/plain
 tests/webtbs/ub1883.pp svneol=native#text/plain
 tests/webtbs/uw0555.pp svneol=native#text/plain

compiler/ncal.pas

@@ -44,7 +44,8 @@ interface
          cnf_new_call,
          cnf_dispose_call,
          cnf_member_call,        { called with implicit methodpointer tree }
-         cnf_uses_varargs        { varargs are used in the declaration }
+         cnf_uses_varargs,       { varargs are used in the declaration }
+         cnf_create_failed       { exception thrown in constructor -> don't call beforedestruction }
        );
        tcallnodeflags = set of tcallnodeflag;
 
@@ -368,14 +369,14 @@ implementation
                 addstatement(statements,cassignmentnode.create(
                   ctypeconvnode.create_internal(cderefnode.create(caddnode.create(addn,
                     caddrnode.create(ctemprefnode.create(params)),
-                    cordconstnode.create(paramssize,ptrinttype,false)
+                    cordconstnode.create(paramssize,ptruinttype,false)
                   )),voidpointertype),
                   ctypeconvnode.create_internal(caddrnode.create_internal(para.value),voidpointertype)))
               else
                 addstatement(statements,cassignmentnode.create(
                   ctypeconvnode.create_internal(cderefnode.create(caddnode.create(addn,
                     caddrnode.create(ctemprefnode.create(params)),
-                    cordconstnode.create(paramssize,ptrinttype,false)
+                    cordconstnode.create(paramssize,ptruinttype,false)
                   )),voidpointertype),
                   ctypeconvnode.create_internal(para.value,voidpointertype)));
 
@@ -1574,26 +1575,30 @@ implementation
                         call afterconstrution, vmt=1 }
                   if (procdefinition.proctypeoption=potype_destructor) then
                     vmttree:=cpointerconstnode.create(0,voidpointertype)
+                  else if (current_procinfo.procdef.proctypeoption=potype_constructor) and
+                          (procdefinition.proctypeoption=potype_constructor) then
+                    vmttree:=cpointerconstnode.create(0,voidpointertype)
                   else
-                    begin
-                      if (current_procinfo.procdef.proctypeoption=potype_constructor) and
-                         (procdefinition.proctypeoption=potype_constructor) then
-                        vmttree:=cpointerconstnode.create(0,voidpointertype)
-                      else
-                        vmttree:=cpointerconstnode.create(1,voidpointertype);
-                    end;
+                    vmttree:=cpointerconstnode.create(1,voidpointertype);
                 end
             else
             { normal call to method like cl1.proc }
               begin
-                { destructor: release instance, vmt=1
+                { destructor:
+                     if not called from exception block in constructor
+                       call beforedestruction and release instance, vmt=1
+                     else
+                       don't call beforedestruction and release instance, vmt=-1
                   constructor:
                     if called from a constructor in the same class using self.create then
                       don't call afterconstruction, vmt=0
                     else
                       call afterconstrution, vmt=1 }
                 if (procdefinition.proctypeoption=potype_destructor) then
-                  vmttree:=cpointerconstnode.create(1,voidpointertype)
+                  if not(cnf_create_failed in callnodeflags) then
+                    vmttree:=cpointerconstnode.create(1,voidpointertype)
+                  else 
+                    vmttree:=cpointerconstnode.create(TConstPtrUInt(-1),voidpointertype)
                 else
                   begin
                     if (current_procinfo.procdef.proctypeoption=potype_constructor) and

compiler/ninl.pas

@@ -1560,7 +1560,7 @@ implementation
                        begin
                          if m_mac in current_settings.modeswitches then
                            begin
-                             hp:=ctypeconvnode.create_internal(left,ptrinttype);
+                             hp:=ctypeconvnode.create_internal(left,ptruinttype);
                              left:=nil;
                              result:=hp;
                            end

compiler/ppu.pas

@@ -43,7 +43,7 @@ type
 {$endif Test_Double_checksum}
 
 const
-  CurrentPPUVersion=75;
+  CurrentPPUVersion=76;
 
 { buffer sizes }
   maxentrysize = 1024;

compiler/psub.pas

@@ -342,11 +342,13 @@ implementation
                 if assigned(srsym) and
                    (srsym.typ=procsym) then
                   begin
-                    { if vmt<>0 then beforedestruction }
+                    { if vmt>0 then beforedestruction }
                     addstatement(newstatement,cifnode.create(
-                        caddnode.create(unequaln,
-                            load_vmt_pointer_node,
-                            cnilnode.create),
+                        caddnode.create(gtn,
+                            ctypeconvnode.create_internal(
+                              load_vmt_pointer_node,ptrsinttype),
+                            ctypeconvnode.create_internal(
+                              cnilnode.create,ptrsinttype)),
                         ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
                         nil));
                   end
@@ -409,17 +411,17 @@ implementation
                     if assigned(srsym) and
                        (srsym.typ=procsym) then
                       begin
-                        { if self<>0 and vmt=1 then freeinstance }
+                        { if self<>0 and vmt<>0 then freeinstance }
                         addstatement(newstatement,cifnode.create(
                             caddnode.create(andn,
                                 caddnode.create(unequaln,
                                     load_self_pointer_node,
                                     cnilnode.create),
-                                caddnode.create(equaln,
+                                caddnode.create(unequaln,
                                     ctypeconvnode.create(
                                         load_vmt_pointer_node,
                                         voidpointertype),
-                                    cpointerconstnode.create(1,voidpointertype))),
+                                    cpointerconstnode.create(0,voidpointertype))),
                             ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
                             nil));
                       end
@@ -482,7 +484,8 @@ implementation
                     caddnode.create(unequaln,
                         load_vmt_pointer_node,
                         cnilnode.create),
-                    ccallnode.create(nil,tprocsym(pd.procsym),pd.procsym.owner,load_self_node,[]),
+                    { 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;
@@ -581,7 +584,6 @@ implementation
             exceptcode:=generate_except_block;
             { Generate code that will be in the try...finally }
             finalcode:=internalstatements(codestatement);
-            addstatement(codestatement,bodyexitcode);
             addstatement(codestatement,final_asmnode);
             { Initialize before try...finally...end frame }
             addstatement(newstatement,loadpara_asmnode);
@@ -595,6 +597,7 @@ implementation
                finalcode,
                exceptcode));
             addstatement(newstatement,exitlabel_asmnode);
+            addstatement(newstatement,bodyexitcode);
             { set flag the implicit finally has been generated }
             include(flags,pi_has_implicit_finally);
           end

compiler/psystem.pas

@@ -189,11 +189,13 @@ implementation
 {$ifdef cpu64bit}
         uinttype:=u64inttype;
         sinttype:=s64inttype;
-        ptrinttype:=u64inttype;
+        ptruinttype:=u64inttype;
+        ptrsinttype:=s64inttype;
 {$else cpu64bit}
         uinttype:=u32inttype;
         sinttype:=s32inttype;
-        ptrinttype:=u32inttype;
+        ptruinttype:=u32inttype;
+        ptrsinttype:=s32inttype;
 {$endif cpu64bit}
         { some other definitions }
         voidpointertype:=tpointerdef.create(voidtype);
@@ -387,11 +389,13 @@ implementation
 {$ifdef cpu64bit}
         uinttype:=u64inttype;
         sinttype:=s64inttype;
-        ptrinttype:=u64inttype;
+        ptruinttype:=u64inttype;
+        ptrsinttype:=s64inttype;
 {$else cpu64bit}
         uinttype:=u32inttype;
         sinttype:=s32inttype;
-        ptrinttype:=u32inttype;
+        ptruinttype:=u32inttype;
+        ptrsinttype:=s32inttype;
 {$endif cpu64bit}
         current_module:=oldcurrentmodule;
       end;

compiler/symdef.pas

@@ -601,8 +601,9 @@ interface
        { default integer type s32inttype on 32 bit systems, s64bittype on 64 bit systems }
        sinttype,
        uinttype,
-       { unsigned ord type with the same size as a pointer }
-       ptrinttype,
+       { unsigned and signed ord type with the same size as a pointer }
+       ptruinttype,
+       ptrsinttype,
        { several types to simulate more or less C++ objects for GDB }
        vmttype,
        vmtarraytype,

tests/webtbs/tw8222.pp

@@ -0,0 +1,307 @@
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+
+{$i-}
+
+uses
+  SysUtils;
+
+type
+  TMyObject1 = class(TObject)
+    constructor Create; virtual;
+    destructor Destroy; override;
+
+    procedure AfterConstruction; override;
+    procedure BeforeDestruction; override;
+
+    class function NewInstance: TObject; override;
+    procedure FreeInstance; override;
+  end;
+
+  TMyObject2 = class(TMyObject1)
+    constructor Create; override;
+    destructor Destroy; override;
+
+    procedure AfterConstruction; override;
+    procedure BeforeDestruction; override;
+
+    class function NewInstance: TObject; override;
+    procedure FreeInstance; override;
+  end;
+
+  TMyObject3 = class(TMyObject2)
+    constructor Create; override;
+    destructor Destroy; override;
+
+    procedure AfterConstruction; override;
+    procedure BeforeDestruction; override;
+
+    class function NewInstance: TObject; override;
+    procedure FreeInstance; override;
+  end;
+
+
+var
+  Depth: Integer;
+  s: string;
+
+{ TMyObject1 }
+
+procedure TMyObject1.AfterConstruction;
+begin
+  s:=s+'1a';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.AfterConstruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2a';
+  finally 
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.AfterConstruction');
+    s:=s+'3a';
+  end;
+  s:=s+'4a';
+end;
+
+procedure TMyObject1.BeforeDestruction;
+begin
+  s:=s+'1b';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.BeforeDestruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2b';
+  finally
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.BeforeDestruction');
+    s:=s+'3b';
+  end;
+  s:=s+'4b';
+end;
+
+constructor TMyObject1.Create;
+begin
+  s:=s+'1c';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.Create'); Inc(Depth); try
+  inherited;
+  s:=s+'2c';
+  raise Exception.Create('');
+  s:=s+'3c';
+  finally
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.Create');
+    s:=s+'4c';
+  end;
+  s:=s+'5c';
+end;
+
+destructor TMyObject1.Destroy;
+begin
+  s:=s+'1d';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.Destroy'); Inc(Depth); try
+  inherited;
+  s:=s+'2d';
+  finally
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.Destroy');
+    s:=s+'3d';
+  end;
+  s:=s+'4d';
+end;
+
+procedure TMyObject1.FreeInstance;
+begin
+  s:=s+'1e';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.FreeInstance'); Inc(Depth); try
+  inherited;
+  s:=s+'2e';
+  finally
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.FreeInstance');
+    s:=s+'3e';
+  end;
+  s:=s+'4e';
+end;
+
+class function TMyObject1.NewInstance: TObject;
+begin
+  s:=s+'1f';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.NewInstance'); Inc(Depth); try
+  Result := inherited NewInstance;
+  s:=s+'2f';
+  finally
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.NewInstance');
+    s:=s+'3f';
+  end;
+  s:=s+'4f';
+end;
+
+{ TMyObject2 }
+
+procedure TMyObject2.AfterConstruction;
+begin
+  s:=s+'1g';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.AfterConstruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2g';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.AfterConstruction'); 
+    s:=s+'3g';
+  end;
+  s:=s+'4g';
+end;
+
+procedure TMyObject2.BeforeDestruction;
+begin
+  s:=s+'1h';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.BeforeDestruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2h';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.BeforeDestruction'); 
+    s:=s+'3h';
+  end;
+  s:=s+'4h';
+end;
+
+constructor TMyObject2.Create;
+begin
+  s:=s+'1i';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.Create'); Inc(Depth); try
+  inherited;
+  s:=s+'2i';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.Create'); 
+    s:=s+'3i';
+  end;
+  s:=s+'4i';
+end;
+
+destructor TMyObject2.Destroy;
+begin
+  s:=s+'1j';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.Destroy'); Inc(Depth); try
+  inherited;
+  s:=s+'2j';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.Destroy'); 
+    s:=s+'3j';
+  end;
+  s:=s+'4j';
+end;
+
+procedure TMyObject2.FreeInstance;
+begin
+  s:=s+'1k';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.FreeInstance'); Inc(Depth); try
+  inherited;
+  s:=s+'2k';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.FreeInstance'); 
+    s:=s+'3k';
+  end;
+  s:=s+'4k';
+end;
+
+class function TMyObject2.NewInstance: TObject;
+begin
+  s:=s+'1l';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.NewInstance'); Inc(Depth); try
+  Result := inherited NewInstance;
+  s:=s+'2l';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.NewInstance'); 
+    s:=s+'3l';
+  end;
+  s:=s+'4l';
+end;
+
+{ TMyObject3 }
+
+procedure TMyObject3.AfterConstruction;
+begin
+  s:=s+'1m';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.AfterConstruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2m';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.AfterConstruction'); 
+    s:=s+'3m';
+  end;
+  s:=s+'4m';
+end;
+
+procedure TMyObject3.BeforeDestruction;
+begin
+  s:=s+'1n';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.BeforeDestruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2n';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.BeforeDestruction'); 
+    s:=s+'3n';
+  end;
+  s:=s+'4n';
+end;
+
+constructor TMyObject3.Create;
+begin
+  s:=s+'1o';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.Create'); Inc(Depth); try
+  inherited;
+  s:=s+'2o';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.Create'); 
+    s:=s+'3o';
+  end;
+  s:=s+'4o';
+end;
+
+destructor TMyObject3.Destroy;
+begin
+  s:=s+'1p';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.Destroy'); Inc(Depth); try
+  inherited;
+  s:=s+'2p';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.Destroy'); 
+    s:=s+'3p';
+  end;
+  s:=s+'4p';
+end;
+
+procedure TMyObject3.FreeInstance;
+begin
+  s:=s+'1q';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.FreeInstance'); Inc(Depth); try
+  inherited;
+  s:=s+'2q';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.FreeInstance'); 
+    s:=s+'3q';
+  end;
+  s:=s+'4q';
+end;
+
+class function TMyObject3.NewInstance: TObject;
+begin
+  s:=s+'1r';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.NewInstance'); Inc(Depth); try
+  Result := inherited NewInstance;
+  s:=s+'2r';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.NewInstance'); 
+    s:=s+'3r';
+  end;
+  s:=s+'4r';
+end;
+
+begin
+  try
+    with TMyObject3.Create do try
+      WriteLn('******');
+      halt(1);
+    finally
+      halt(1);
+      Free;
+    end;
+  finally
+    writeln(s);
+    if (s <> '1r1l1f2f3f4f2l3l4l2r3r4r1o1i1c2c4c3i3o1p1j1d2d3d4d2j3j4j2p3p4p1q1k1e2e3e4e2k3k4k2q3q4q') then
+      halt(1);
+    halt(0);
+  end;
+end.
+

tests/webtbs/tw8222a.pp

@@ -0,0 +1,308 @@
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+
+{$i-}
+
+uses
+  SysUtils;
+
+type
+  TMyObject1 = class(TObject)
+    constructor Create; virtual;
+    destructor Destroy; override;
+
+    procedure AfterConstruction; override;
+    procedure BeforeDestruction; override;
+
+    class function NewInstance: TObject; override;
+    procedure FreeInstance; override;
+  end;
+
+  TMyObject2 = class(TMyObject1)
+    constructor Create; override;
+    destructor Destroy; override;
+
+    procedure AfterConstruction; override;
+    procedure BeforeDestruction; override;
+
+    class function NewInstance: TObject; override;
+    procedure FreeInstance; override;
+  end;
+
+  TMyObject3 = class(TMyObject2)
+    constructor Create; override;
+    destructor Destroy; override;
+
+    procedure AfterConstruction; override;
+    procedure BeforeDestruction; override;
+
+    class function NewInstance: TObject; override;
+    procedure FreeInstance; override;
+  end;
+
+
+var
+  Depth: Integer;
+  s: string;
+
+{ TMyObject1 }
+
+procedure TMyObject1.AfterConstruction;
+begin
+  s:=s+'1a';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.AfterConstruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2a';
+  finally 
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.AfterConstruction');
+    s:=s+'3a';
+  end;
+  s:=s+'4a';
+end;
+
+procedure TMyObject1.BeforeDestruction;
+begin
+  s:=s+'1b';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.BeforeDestruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2b';
+  finally
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.BeforeDestruction');
+    s:=s+'3b';
+  end;
+  s:=s+'4b';
+end;
+
+constructor TMyObject1.Create;
+begin
+  s:=s+'1c';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.Create'); Inc(Depth); try
+  inherited;
+  s:=s+'2c';
+  raise Exception.Create('');
+  s:=s+'3c';
+  finally
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.Create');
+    s:=s+'4c';
+  end;
+  s:=s+'5c';
+end;
+
+destructor TMyObject1.Destroy;
+begin
+  s:=s+'1d';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.Destroy'); Inc(Depth); try
+  inherited;
+  s:=s+'2d';
+  finally
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.Destroy');
+    s:=s+'3d';
+  end;
+  s:=s+'4d';
+end;
+
+procedure TMyObject1.FreeInstance;
+begin
+  s:=s+'1e';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.FreeInstance'); Inc(Depth); try
+  inherited;
+  s:=s+'2e';
+  finally
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.FreeInstance');
+    s:=s+'3e';
+  end;
+  s:=s+'4e';
+end;
+
+class function TMyObject1.NewInstance: TObject;
+begin
+  s:=s+'1f';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.NewInstance'); Inc(Depth); try
+  Result := inherited NewInstance;
+  s:=s+'2f';
+  finally
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.NewInstance');
+    s:=s+'3f';
+  end;
+  s:=s+'4f';
+end;
+
+{ TMyObject2 }
+
+procedure TMyObject2.AfterConstruction;
+begin
+  s:=s+'1g';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.AfterConstruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2g';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.AfterConstruction'); 
+    s:=s+'3g';
+  end;
+  s:=s+'4g';
+end;
+
+procedure TMyObject2.BeforeDestruction;
+begin
+  s:=s+'1h';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.BeforeDestruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2h';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.BeforeDestruction'); 
+    s:=s+'3h';
+  end;
+  s:=s+'4h';
+end;
+
+constructor TMyObject2.Create;
+begin
+  s:=s+'1i';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.Create'); Inc(Depth); try
+  inherited;
+  s:=s+'2i';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.Create'); 
+    s:=s+'3i';
+  end;
+  s:=s+'4i';
+end;
+
+destructor TMyObject2.Destroy;
+begin
+  s:=s+'1j';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.Destroy'); Inc(Depth); try
+  raise Exception.Create('');
+  inherited;
+  s:=s+'2j';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.Destroy'); 
+    s:=s+'3j';
+  end;
+  s:=s+'4j';
+end;
+
+procedure TMyObject2.FreeInstance;
+begin
+  s:=s+'1k';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.FreeInstance'); Inc(Depth); try
+  inherited;
+  s:=s+'2k';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.FreeInstance'); 
+    s:=s+'3k';
+  end;
+  s:=s+'4k';
+end;
+
+class function TMyObject2.NewInstance: TObject;
+begin
+  s:=s+'1l';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.NewInstance'); Inc(Depth); try
+  Result := inherited NewInstance;
+  s:=s+'2l';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.NewInstance'); 
+    s:=s+'3l';
+  end;
+  s:=s+'4l';
+end;
+
+{ TMyObject3 }
+
+procedure TMyObject3.AfterConstruction;
+begin
+  s:=s+'1m';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.AfterConstruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2m';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.AfterConstruction'); 
+    s:=s+'3m';
+  end;
+  s:=s+'4m';
+end;
+
+procedure TMyObject3.BeforeDestruction;
+begin
+  s:=s+'1n';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.BeforeDestruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2n';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.BeforeDestruction'); 
+    s:=s+'3n';
+  end;
+  s:=s+'4n';
+end;
+
+constructor TMyObject3.Create;
+begin
+  s:=s+'1o';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.Create'); Inc(Depth); try
+  inherited;
+  s:=s+'2o';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.Create'); 
+    s:=s+'3o';
+  end;
+  s:=s+'4o';
+end;
+
+destructor TMyObject3.Destroy;
+begin
+  s:=s+'1p';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.Destroy'); Inc(Depth); try
+  inherited;
+  s:=s+'2p';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.Destroy'); 
+    s:=s+'3p';
+  end;
+  s:=s+'4p';
+end;
+
+procedure TMyObject3.FreeInstance;
+begin
+  s:=s+'1q';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.FreeInstance'); Inc(Depth); try
+  inherited;
+  s:=s+'2q';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.FreeInstance'); 
+    s:=s+'3q';
+  end;
+  s:=s+'4q';
+end;
+
+class function TMyObject3.NewInstance: TObject;
+begin
+  s:=s+'1r';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.NewInstance'); Inc(Depth); try
+  Result := inherited NewInstance;
+  s:=s+'2r';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.NewInstance'); 
+    s:=s+'3r';
+  end;
+  s:=s+'4r';
+end;
+
+begin
+  try
+    with TMyObject3.Create do try
+      WriteLn('******');
+      halt(1);
+    finally
+      halt(1);
+      Free;
+    end;
+  finally
+    writeln(s);
+    if (s <> '1r1l1f2f3f4f2l3l4l2r3r4r1o1i1c2c4c3i3o1p1j3j3p') then
+      halt(1);
+    halt(0);
+  end;
+end.
+

tests/webtbs/tw8222b.pp

@@ -0,0 +1,314 @@
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+
+{$i-}
+
+uses
+  SysUtils;
+
+type
+  TMyObject1 = class(TObject)
+    constructor Create; virtual;
+    destructor Destroy; override;
+
+    procedure AfterConstruction; override;
+    procedure BeforeDestruction; override;
+
+    class function NewInstance: TObject; override;
+    procedure FreeInstance; override;
+  end;
+
+  TMyObject2 = class(TMyObject1)
+    constructor Create; override;
+    destructor Destroy; override;
+
+    procedure AfterConstruction; override;
+    procedure BeforeDestruction; override;
+
+    class function NewInstance: TObject; override;
+    procedure FreeInstance; override;
+  end;
+
+  TMyObject3 = class(TMyObject2)
+    constructor Create; override;
+    destructor Destroy; override;
+
+    procedure AfterConstruction; override;
+    procedure BeforeDestruction; override;
+
+    class function NewInstance: TObject; override;
+    procedure FreeInstance; override;
+  end;
+
+
+var
+  Depth: Integer;
+  s: string;
+
+{ TMyObject1 }
+
+procedure TMyObject1.AfterConstruction;
+begin
+  s:=s+'1a';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.AfterConstruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2a';
+  finally 
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.AfterConstruction');
+    s:=s+'3a';
+  end;
+  s:=s+'4a';
+end;
+
+procedure TMyObject1.BeforeDestruction;
+begin
+  s:=s+'1b';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.BeforeDestruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2b';
+  finally
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.BeforeDestruction');
+    s:=s+'3b';
+  end;
+  s:=s+'4b';
+end;
+
+constructor TMyObject1.Create;
+begin
+  s:=s+'1c';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.Create'); Inc(Depth); try
+  inherited;
+  s:=s+'2c';
+  s:=s+'3c';
+  finally
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.Create');
+    s:=s+'4c';
+  end;
+  s:=s+'5c';
+end;
+
+destructor TMyObject1.Destroy;
+begin
+  s:=s+'1d';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.Destroy'); Inc(Depth); try
+  inherited;
+  s:=s+'2d';
+  finally
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.Destroy');
+    s:=s+'3d';
+  end;
+  s:=s+'4d';
+end;
+
+procedure TMyObject1.FreeInstance;
+begin
+  s:=s+'1e';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.FreeInstance'); Inc(Depth); try
+  inherited;
+  s:=s+'2e';
+  finally
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.FreeInstance');
+    s:=s+'3e';
+  end;
+  s:=s+'4e';
+end;
+
+class function TMyObject1.NewInstance: TObject;
+begin
+  s:=s+'1f';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject1.NewInstance'); Inc(Depth); try
+  Result := inherited NewInstance;
+  s:=s+'2f';
+  finally
+    Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject1.NewInstance');
+    s:=s+'3f';
+  end;
+  s:=s+'4f';
+end;
+
+{ TMyObject2 }
+
+procedure TMyObject2.AfterConstruction;
+begin
+  s:=s+'1g';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.AfterConstruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2g';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.AfterConstruction'); 
+    s:=s+'3g';
+  end;
+  s:=s+'4g';
+end;
+
+procedure TMyObject2.BeforeDestruction;
+begin
+  s:=s+'1h';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.BeforeDestruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2h';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.BeforeDestruction'); 
+    s:=s+'3h';
+  end;
+  s:=s+'4h';
+end;
+
+constructor TMyObject2.Create;
+begin
+  s:=s+'1i';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.Create'); Inc(Depth); try
+  inherited;
+  s:=s+'2i';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.Create'); 
+    s:=s+'3i';
+  end;
+  s:=s+'4i';
+end;
+
+destructor TMyObject2.Destroy;
+begin
+  s:=s+'1j';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.Destroy'); Inc(Depth); try
+  inherited;
+  s:=s+'2j';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.Destroy'); 
+    s:=s+'3j';
+  end;
+  s:=s+'4j';
+end;
+
+procedure TMyObject2.FreeInstance;
+begin
+  s:=s+'1k';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.FreeInstance'); Inc(Depth); try
+  inherited;
+  s:=s+'2k';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.FreeInstance'); 
+    s:=s+'3k';
+  end;
+  s:=s+'4k';
+end;
+
+class function TMyObject2.NewInstance: TObject;
+begin
+  s:=s+'1l';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject2.NewInstance'); Inc(Depth); try
+  Result := inherited NewInstance;
+  s:=s+'2l';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject2.NewInstance'); 
+    s:=s+'3l';
+  end;
+  s:=s+'4l';
+end;
+
+{ TMyObject3 }
+
+procedure TMyObject3.AfterConstruction;
+begin
+  s:=s+'1m';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.AfterConstruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2m';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.AfterConstruction'); 
+    s:=s+'3m';
+  end;
+  s:=s+'4m';
+end;
+
+procedure TMyObject3.BeforeDestruction;
+begin
+  s:=s+'1n';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.BeforeDestruction'); Inc(Depth); try
+  inherited;
+  s:=s+'2n';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.BeforeDestruction'); 
+    s:=s+'3n';
+  end;
+  s:=s+'4n';
+end;
+
+constructor TMyObject3.Create;
+begin
+  s:=s+'1o';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.Create'); Inc(Depth); try
+  inherited;
+  s:=s+'2o';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.Create'); 
+    s:=s+'3o';
+  end;
+  s:=s+'4o';
+end;
+
+destructor TMyObject3.Destroy;
+begin
+  s:=s+'1p';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.Destroy'); Inc(Depth); try
+  inherited;
+  s:=s+'2p';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.Destroy'); 
+    s:=s+'3p';
+  end;
+  s:=s+'4p';
+end;
+
+procedure TMyObject3.FreeInstance;
+begin
+  s:=s+'1q';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.FreeInstance'); Inc(Depth); try
+  inherited;
+  s:=s+'2q';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.FreeInstance'); 
+    s:=s+'3q';
+  end;
+  s:=s+'4q';
+end;
+
+class function TMyObject3.NewInstance: TObject;
+begin
+  s:=s+'1r';
+  WriteLn(StringOfChar(' ', Depth * 2), '-> TMyObject3.NewInstance'); Inc(Depth); try
+  Result := inherited NewInstance;
+  s:=s+'2r';
+  finally
+     Dec(Depth); WriteLn(StringOfChar(' ', Depth * 2), '<- TMyObject3.NewInstance'); 
+    s:=s+'3r';
+  end;
+  s:=s+'4r';
+end;
+
+begin
+  try
+    with TMyObject3.Create do try
+      writeln(s);
+      if (s <> '1r1l1f2f3f4f2l3l4l2r3r4r1o1i1c2c3c4c5c2i3i4i2o3o4o1m1g1a2a3a4a2g3g4g2m3m4m') then
+        halt(1);
+      s:='ok';
+    finally
+      if (s<>'ok') then
+        halt(1);
+      Free;
+      writeln(s);
+      if (s<>'ok1n1h1b2b3b4b2h3h4h2n3n4n1p1j1d2d3d4d2j3j4j2p3p4p1q1k1e2e3e4e2k3k4k2q3q4q') then
+        halt(4);
+      s:='ok2';
+    end;
+  finally
+    if s<>'ok2' then
+      halt(2);
+    s:='ok3';
+  end;
+  if s<>'ok3' then
+    halt(3);
+end.
+