diff --git a/.gitattributes b/.gitattributes index 628f794db3..8929957c92 100644 --- a/.gitattributes +++ b/.gitattributes @@ -8545,6 +8545,7 @@ 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/tw11896.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 diff --git a/compiler/ncal.pas b/compiler/ncal.pas index aa008bc8b8..af72ef2cdb 100644 --- a/compiler/ncal.pas +++ b/compiler/ncal.pas @@ -1575,14 +1575,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) @@ -1601,7 +1608,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) diff --git a/tests/test/cg/tcalcla1.pp b/tests/test/cg/tcalcla1.pp index fb01f34dc4..d50ad23e4b 100644 --- a/tests/test/cg/tcalcla1.pp +++ b/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 diff --git a/tests/webtbs/tw11896.pp b/tests/webtbs/tw11896.pp new file mode 100644 index 0000000000..34f6daefda --- /dev/null +++ b/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. +