diff --git a/.gitattributes b/.gitattributes index cd69213ce6..f72d1a457b 100644 --- a/.gitattributes +++ b/.gitattributes @@ -10350,6 +10350,7 @@ tests/webtbs/tw16188.pp svneol=native#text/plain tests/webtbs/tw1622.pp svneol=native#text/plain tests/webtbs/tw16222.pp svneol=native#text/pascal tests/webtbs/tw1623.pp svneol=native#text/plain +tests/webtbs/tw16311.pp svneol=native#text/plain tests/webtbs/tw1634.pp svneol=native#text/plain tests/webtbs/tw1658.pp svneol=native#text/plain tests/webtbs/tw1677.pp svneol=native#text/plain diff --git a/compiler/psub.pas b/compiler/psub.pas index cc37a93632..d0d40982da 100644 --- a/compiler/psub.pas +++ b/compiler/psub.pas @@ -388,30 +388,6 @@ implementation { has been called, so it may no longer be valid (JM) } oldlocalswitches:=current_settings.localswitches; current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range]; - { 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 - { 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)); - end - else - internalerror(200305106); - end; { a destructor needs a help procedure } if (current_procinfo.procdef.proctypeoption=potype_destructor) then @@ -574,6 +550,47 @@ 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 ****************************************************************************} @@ -641,6 +658,7 @@ 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 diff --git a/tests/webtbs/tw16311.pp b/tests/webtbs/tw16311.pp new file mode 100644 index 0000000000..9b395edf7b --- /dev/null +++ b/tests/webtbs/tw16311.pp @@ -0,0 +1,85 @@ +{ %opt=-gh } + +{$APPTYPE CONSOLE} + +{$ifdef fpc} + {$mode delphi} +{$endif} + +uses SysUtils; + +var + CreatedCount, DestroyedCount: Integer; + +type + + { TCntObject } + + TCntObject = class(TObject) + public + constructor Create; virtual; + destructor Destroy; override; + end; + + { TMyObject } + + TMyObject = class(TCntObject) + private + FSubObject: TCntObject; + public + constructor Create; override; + destructor Destroy; override; + procedure AfterConstruction; override; + end; + +{ TCntObject } + +constructor TCntObject.Create; +begin + Inc(CreatedCount); +end; + +destructor TCntObject.Destroy; +begin + Inc(DestroyedCount); + inherited Destroy; +end; + +{ TMyObject } + +constructor TMyObject.Create; +begin + inherited Create; + FSubObject := TCntObject.Create; +end; + +destructor TMyObject.Destroy; +begin + FSubObject.Free; + inherited Destroy; +end; + +procedure TMyObject.AfterConstruction; +begin + raise Exception.Create('OnAfterConstruction'); +end; + +var + A: TMyObject; +begin + HaltOnNotReleased := true; + CreatedCount := 0; + DestroyedCount := 0; + try + A := nil; + try + A := TMyObject.Create; + finally + A.Free; + end; + except + writeln('created objects = ', CreatedCount); + writeln('destroyed objects = ', DestroyedCount); + writeln; + end; +end.