paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-05-31 04:22:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fixed execution order of implicit finalization and class destructors: first

Browse Source 
the latter, then the former

git-svn-id: trunk@38716 -
This commit is contained in:
Jonas Maebe 2018-04-08 15:41:00 +00:00
parent 77cf535e21
commit cb7730a423
6 changed files with 180 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -15846,6 +15846,7 @@ tests/webtbs/tw2916.pp svneol=native#text/plain
tests/webtbs/tw2920.pp svneol=native#text/plain
tests/webtbs/tw2923.pp svneol=native#text/plain
tests/webtbs/tw29244.pp svneol=native#text/pascal
tests/webtbs/tw29245.pp svneol=native#text/plain
tests/webtbs/tw29250.pp svneol=native#text/pascal
tests/webtbs/tw2926.pp svneol=native#text/plain
tests/webtbs/tw2927.pp svneol=native#text/plain
@ -16702,6 +16703,7 @@ tests/webtbs/uw28442.pp svneol=native#text/pascal
tests/webtbs/uw28766.pp svneol=native#text/pascal
tests/webtbs/uw28964.pp svneol=native#text/plain
tests/webtbs/uw2920.pp svneol=native#text/plain
tests/webtbs/uw29245.pp svneol=native#text/plain
tests/webtbs/uw2956.pp svneol=native#text/plain
tests/webtbs/uw2984.pp svneol=native#text/plain
tests/webtbs/uw3103.pp svneol=native#text/plain

6
compiler/ncal.pas
View File

@ -54,8 +54,9 @@ interface
cnf_objc_id_call, { the procedure is a member call via id -> any ObjC method of any ObjC type in scope is fair game }
cnf_unit_specified, { the unit in which the procedure has to be searched has been specified }
cnf_call_never_returns, { information for the dfa that a subroutine never returns }
cnf_call_self_node_done { the call_self_node has been generated if necessary
cnf_call_self_node_done,{ the call_self_node has been generated if necessary
(to prevent it from potentially happening again in a wrong context in case of constant propagation or so) }
cnf_ignore_visibility { internally generated call that should ignore visibility checks }
);
tcallnodeflags = set of tcallnodeflag;
@ -3596,7 +3597,8 @@ implementation
end;
{ ignore possible private for properties or in delphi mode for anon. inherited (FK) }
ignorevisibility:=(nf_isproperty in flags) or
((m_delphi in current_settings.modeswitches) and (cnf_anon_inherited in callnodeflags));
((m_delphi in current_settings.modeswitches) and (cnf_anon_inherited in callnodeflags)) or
(cnf_ignore_visibility in callnodeflags);
candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility,
not(nf_isproperty in flags),cnf_objc_id_call in callnodeflags,cnf_unit_specified in callnodeflags,
callnodeflags*[cnf_anon_inherited,cnf_inherited]=[],cnf_anon_inherited in callnodeflags,spezcontext);

120
compiler/ngenutil.pas
View File

@ -48,6 +48,8 @@ interface
class function initialize_data_node(p:tnode; force: boolean):tnode; virtual;
class function finalize_data_node(p:tnode):tnode; virtual;
strict protected
type
tstructinifinipotype = potype_class_constructor..potype_class_destructor;
class procedure sym_maybe_initialize(p: TObject; arg: pointer);
{ generates the code for finalisation of local variables }
class procedure local_varsyms_finalize(p:TObject;arg:pointer);
@ -55,6 +57,7 @@ interface
all local (static) typed consts }
class procedure static_syms_finalize(p: TObject; arg: pointer);
class procedure sym_maybe_finalize(var stat: tstatementnode; sym: tsym);
class procedure append_struct_initfinis(u: tmodule; initfini: tstructinifinipotype; var stat: tstatementnode);
public
class procedure procdef_block_add_implicit_initialize_nodes(pd: tprocdef; var stat: tstatementnode);
class procedure procdef_block_add_implicit_finalize_nodes(pd: tprocdef; var stat: tstatementnode);
@ -421,6 +424,47 @@ implementation
end;
procedure AddToStructInits(p:TObject;arg:pointer);
var
StructList: TFPList absolute arg;
begin
if (tdef(p).typ in [objectdef,recorddef]) and
not (df_generic in tdef(p).defoptions) then
begin
{ first add the class... }
if ([oo_has_class_constructor,oo_has_class_destructor] * tabstractrecorddef(p).objectoptions <> []) then
StructList.Add(p);
{ ... and then also add all subclasses }
tabstractrecorddef(p).symtable.deflist.foreachcall(@AddToStructInits,arg);
end;
end;
class procedure tnodeutils.append_struct_initfinis(u: tmodule; initfini: tstructinifinipotype; var stat: tstatementnode);
var
structlist: tfplist;
i: integer;
pd: tprocdef;
begin
structlist:=tfplist.Create;
if assigned(u.globalsymtable) then
u.globalsymtable.DefList.ForEachCall(@AddToStructInits,structlist);
u.localsymtable.DefList.ForEachCall(@AddToStructInits,structlist);
{ write structures }
for i:=0 to structlist.Count-1 do
begin
pd:=tabstractrecorddef(structlist[i]).find_procdef_bytype(initfini);
if assigned(pd) then
begin
{ class constructors are private -> ignore visibility checks }
addstatement(stat,
ccallnode.create(nil,tprocsym(pd.procsym),pd.owner,nil,[cnf_ignore_visibility],nil))
end;
end;
structlist.free;
end;
class procedure tnodeutils.procdef_block_add_implicit_initialize_nodes(pd: tprocdef; var stat: tstatementnode);
begin
{ initialize local data like ansistrings }
@ -432,6 +476,9 @@ implementation
if assigned(current_module.globalsymtable) then
TSymtable(current_module.globalsymtable).SymList.ForEachCall(@sym_maybe_initialize,@stat);
TSymtable(current_module.localsymtable).SymList.ForEachCall(@sym_maybe_initialize,@stat);
{ insert class constructors }
if (current_module.flags and uf_classinits) <> 0 then
append_struct_initfinis(current_module, potype_class_constructor, stat);
end;
{ units have seperate code for initilization and finalization }
potype_unitfinalize: ;
@ -453,6 +500,9 @@ implementation
case current_procinfo.procdef.proctypeoption of
potype_unitfinalize:
begin
{ insert class destructors }
if (current_module.flags and uf_classinits) <> 0 then
append_struct_initfinis(current_module, potype_class_destructor, stat);
{ this is also used for initialization of variables in a
program which does not have a globalsymtable }
if assigned(current_module.globalsymtable) then
@ -894,82 +944,16 @@ implementation
end;
procedure AddToStructInits(p:TObject;arg:pointer);
var
StructList: TFPList absolute arg;
begin
if (tdef(p).typ in [objectdef,recorddef]) and
not (df_generic in tdef(p).defoptions) then
begin
{ first add the class... }
if ([oo_has_class_constructor,oo_has_class_destructor] * tabstractrecorddef(p).objectoptions <> []) then
StructList.Add(p);
{ ... and then also add all subclasses }
tabstractrecorddef(p).symtable.deflist.foreachcall(@AddToStructInits,arg);
end;
end;
class function tnodeutils.get_init_final_list:tfplist;
procedure append_struct_inits(u:tmodule);
var
i : integer;
structlist : tfplist;
pd : tprocdef;
entry : pinitfinalentry;
begin
structlist:=tfplist.Create;
if assigned(u.globalsymtable) then
u.globalsymtable.DefList.ForEachCall(@AddToStructInits,structlist);
u.localsymtable.DefList.ForEachCall(@AddToStructInits,structlist);
{ write structures }
for i:=0 to structlist.Count-1 do
begin
new(entry);
entry^.module:=u;
pd:=tabstractrecorddef(structlist[i]).find_procdef_bytype(potype_class_constructor);
if assigned(pd) then
begin
entry^.initfunc:=pd.mangledname;
entry^.initpd:=pd;
end
else
begin
entry^.initfunc:='';
entry^.initpd:=nil;
end;
pd := tabstractrecorddef(structlist[i]).find_procdef_bytype(potype_class_destructor);
if assigned(pd) then
begin
entry^.finifunc:=pd.mangledname;
entry^.finipd:=pd;
end
else
begin
entry^.finifunc:='';
entry^.finipd:=nil;
end;
if assigned(entry^.finipd) or assigned(entry^.initpd) then
result.add(entry)
else
{ AddToStructInits only adds structs that have either a class constructor or destructor or both }
internalerror(2017051902);
end;
structlist.free;
end;
var
hp : tused_unit;
entry : pinitfinalentry;
begin
result:=tfplist.create;
{ Insert initialization/finalization of the used units }
hp:=tused_unit(usedunits.first);
while assigned(hp) do
begin
{ insert class constructors/destructors of the unit }
if (hp.u.flags and uf_classinits) <> 0 then
append_struct_inits(hp.u);
if (hp.u.flags and (uf_init or uf_finalize))<>0 then
begin
new(entry);
@ -989,8 +973,6 @@ implementation
hp:=tused_unit(hp.next);
end;
if (current_module.flags and uf_classinits) <> 0 then
append_struct_inits(current_module);
{ Insert initialization/finalization of the program }
if (current_module.flags and (uf_init or uf_finalize))<>0 then
begin

47
compiler/symtable.pas
View File

@ -70,7 +70,7 @@ interface
procedure allprivatesused;
procedure check_forwards;
procedure checklabels;
function needs_init_final : boolean;
function needs_init_final : boolean; virtual;
procedure testfordefaultproperty(sym:TObject;arg:pointer);
procedure register_children;
end;
@ -226,7 +226,9 @@ interface
function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
function findnamespace(const n:string):TSymEntry;virtual;
function iscurrentunit:boolean;override;
function needs_init_final: boolean; override;
procedure insertunit(sym:TSymEntry);
function has_class_condestructors: boolean;
end;
tglobalsymtable = class(tabstractuniTSymtable)
@ -2420,6 +2422,23 @@ implementation
);
end;
function tabstractuniTSymtable.needs_init_final: boolean;
begin
if not init_final_check_done then
begin
result:=inherited needs_init_final;
if not result then
begin
result:=has_class_condestructors;
if result then
include(tableoptions,sto_needs_init_final);
end;
end;
result:=sto_needs_init_final in tableoptions;
end;
procedure tabstractuniTSymtable.insertunit(sym:TSymEntry);
var
p:integer;
@ -2444,6 +2463,32 @@ implementation
end;
end;
procedure CheckForClassConDestructors(p:TObject;arg:pointer);
var
result: pboolean absolute arg;
begin
if result^ then
exit;
if (tdef(p).typ in [objectdef,recorddef]) and
not (df_generic in tdef(p).defoptions) then
begin
{ first check the class... }
if ([oo_has_class_constructor,oo_has_class_destructor] * tabstractrecorddef(p).objectoptions <> []) then
result^:=true;;
{ ... and then also check all subclasses }
if not result^ then
tabstractrecorddef(p).symtable.deflist.foreachcall(@CheckForClassConDestructors,arg);
end;
end;
function tabstractuniTSymtable.has_class_condestructors: boolean;
begin
result:=false;
deflist.foreachcall(@CheckForClassConDestructors,@result);
end;
{****************************************************************************
TStaticSymtable
****************************************************************************}

36
tests/webtbs/tw29245.pp Normal file
View File

@ -0,0 +1,36 @@
{ %opt=-gh }
{$mode delphi}
uses
uw29245;
type
TBar = class
class var
F: array of TObject;
strict private
class constructor Create;
class destructor Destroy;
end;
class constructor TBar.Create;
begin
writeln('tbar class constructor');
SetLength(F, 10);
end;
class destructor TBar.Destroy;
begin
writeln('tbar class destructor');
if length(Tbar.F)<>10 then
halt(5);
end;
begin
HaltOnNotReleased := true;
writeln('main program');
if length(TBar.F)<>10 then
halt(4);
end.

41
tests/webtbs/uw29245.pp Normal file
View File

@ -0,0 +1,41 @@
unit uw29245;
{$mode delphi}
interface
type
TFoo = class
class var
F: array of TObject;
private
class constructor Create;
class destructor Destroy;
end;
implementation
class constructor TFoo.Create;
begin
writeln('tfoo class constructor');
SetLength(F, 10);
end;
class destructor TFoo.Destroy;
begin
writeln('tfoo class destructor');
if length(TFOO.F)<>10 then
halt(3);
end;
initialization
writeln('unit initialization');
if length(TFOO.F)<>10 then
halt(1);
finalization
writeln('unit finalization');
if length(TFOO.F)<>10 then
halt(2);
end.