paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-15 23:29:13 +02:00
Code Issues Packages Projects Releases Wiki Activity

* put the call to afterconstructor inside the implicit try/catch block

Browse Source 
block of the constructor, so that exceptions thrown there also
    properly abort construction (mantis #16311)

git-svn-id: trunk@15156 -
This commit is contained in:
Jonas Maebe 2010-04-21 20:06:54 +00:00
parent 4a934bdb33
commit f2e1819bae
3 changed files with 128 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -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

66
compiler/psub.pas
View File

@ -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

85
tests/webtbs/tw16311.pp Normal file
View File

@ -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.