paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-01 11:49:37 +01:00
Code Issues Packages Projects Releases Wiki Activity

compiler: add class constructors, class destructors to the initfinal table as regular initialization/finalization sections (class constructors is still not striped away with the class)

Browse Source 
git-svn-id: trunk@15143 -
This commit is contained in:
paul 2010-04-15 07:37:41 +00:00
parent ab551a2662
commit ceccce93f5
6 changed files with 130 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
compiler/nflw.pas
View File

@ -556,7 +556,7 @@ begin
if enumerator_is_class then
begin
{ insert a try-finally and call the destructor for the enumerator in the finally section }
enumerator_destructor:=tobjectdef(enumerator_get.returndef).Finddestructor;
enumerator_destructor:=tobjectdef(enumerator_get.returndef).find_destructor;
if assigned(enumerator_destructor) then
begin
whileloopnode:=ctryfinallynode.create(
@ -577,7 +577,7 @@ begin
if is_object(enumerator_get.returndef) then
begin
// call the object destructor too
enumerator_destructor:=tobjectdef(enumerator_get.returndef).Finddestructor;
enumerator_destructor:=tobjectdef(enumerator_get.returndef).find_destructor;
if assigned(enumerator_destructor) then
begin
addstatement(loopstatement,

4
compiler/pdecobj.pas
View File

@ -40,7 +40,7 @@ implementation
symbase,symsym,symtable,
node,nld,nmem,ncon,ncnv,ncal,
fmodule,scanner,
pbase,pexpr,pdecsub,pdecvar,ptype,pdecl
pbase,pexpr,pdecsub,pdecvar,ptype,pdecl,ppu
;
const
@ -68,6 +68,7 @@ implementation
Message(parser_e_no_paras_for_class_constructor);
consume(_SEMICOLON);
include(current_objectdef.objectoptions,oo_has_class_constructor);
current_module.flags:=current_module.flags or uf_classinits;
{ no return value }
pd.returndef:=voidtype;
result:=pd;
@ -180,6 +181,7 @@ implementation
Message(parser_e_no_paras_for_class_destructor);
consume(_SEMICOLON);
include(current_objectdef.objectoptions,oo_has_class_destructor);
current_module.flags:=current_module.flags or uf_classinits;
{ no return value }
pd.returndef:=voidtype;
result:=pd;

95
compiler/pmodules.pas
View File

@ -376,46 +376,89 @@ implementation
ResourceStringTables.free;
end;
procedure AddToClasInits(p:TObject;arg:pointer);
var
ClassList: TFPList absolute arg;
begin
if (tdef(p).typ=objectdef) and
([oo_has_class_constructor,oo_has_class_destructor] * tobjectdef(p).objectoptions <> []) then
ClassList.Add(p);
end;
procedure InsertInitFinalTable;
var
hp : tused_unit;
unitinits : TAsmList;
count : longint;
procedure write_class_inits(u: tmodule);
var
i: integer;
classlist: TFPList;
pd: tprocdef;
begin
classlist := TFPList.Create;
if assigned(u.globalsymtable) then
u.globalsymtable.DefList.ForEachCall(@AddToClasInits,classlist);
u.localsymtable.DefList.ForEachCall(@AddToClasInits,classlist);
{ write classes }
for i := 0 to classlist.Count - 1 do
begin
pd := tobjectdef(classlist[i]).find_procdef_bytype(potype_class_constructor);
if assigned(pd) then
unitinits.concat(Tai_const.Createname(pd.mangledname,0))
else
unitinits.concat(Tai_const.Create_pint(0));
pd := tobjectdef(classlist[i]).find_procdef_bytype(potype_class_destructor);
if assigned(pd) then
unitinits.concat(Tai_const.Createname(pd.mangledname,0))
else
unitinits.concat(Tai_const.Create_pint(0));
inc(count);
end;
classlist.free;
end;
begin
unitinits:=TAsmList.Create;
count:=0;
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
write_class_inits(hp.u);
{ call the unit init code and make it external }
if (hp.u.flags and (uf_init or uf_finalize))<>0 then
begin
if (hp.u.flags and uf_init)<>0 then
unitinits.concat(Tai_const.Createname(make_mangledname('INIT$',hp.u.globalsymtable,''),0))
else
unitinits.concat(Tai_const.Create_sym(nil));
if (hp.u.flags and uf_finalize)<>0 then
unitinits.concat(Tai_const.Createname(make_mangledname('FINALIZE$',hp.u.globalsymtable,''),0))
else
unitinits.concat(Tai_const.Create_sym(nil));
inc(count);
end;
begin
if (hp.u.flags and uf_init)<>0 then
unitinits.concat(Tai_const.Createname(make_mangledname('INIT$',hp.u.globalsymtable,''),0))
else
unitinits.concat(Tai_const.Create_sym(nil));
if (hp.u.flags and uf_finalize)<>0 then
unitinits.concat(Tai_const.Createname(make_mangledname('FINALIZE$',hp.u.globalsymtable,''),0))
else
unitinits.concat(Tai_const.Create_sym(nil));
inc(count);
end;
hp:=tused_unit(hp.next);
end;
{ insert class constructors/destructor of the program }
if (current_module.flags and uf_classinits) <> 0 then
write_class_inits(current_module);
{ Insert initialization/finalization of the program }
if (current_module.flags and (uf_init or uf_finalize))<>0 then
begin
if (current_module.flags and uf_init)<>0 then
unitinits.concat(Tai_const.Createname(make_mangledname('INIT$',current_module.localsymtable,''),0))
else
unitinits.concat(Tai_const.Create_sym(nil));
if (current_module.flags and uf_finalize)<>0 then
unitinits.concat(Tai_const.Createname(make_mangledname('FINALIZE$',current_module.localsymtable,''),0))
else
unitinits.concat(Tai_const.Create_sym(nil));
inc(count);
end;
begin
if (current_module.flags and uf_init)<>0 then
unitinits.concat(Tai_const.Createname(make_mangledname('INIT$',current_module.localsymtable,''),0))
else
unitinits.concat(Tai_const.Create_sym(nil));
if (current_module.flags and uf_finalize)<>0 then
unitinits.concat(Tai_const.Createname(make_mangledname('FINALIZE$',current_module.localsymtable,''),0))
else
unitinits.concat(Tai_const.Create_sym(nil));
inc(count);
end;
{ Insert TableCount,InitCount at start }
unitinits.insert(Tai_const.Create_32bit(0));
unitinits.insert(Tai_const.Create_32bit(count));
@ -429,7 +472,7 @@ implementation
end;
procedure insertmemorysizes;
procedure InsertMemorySizes;
{$IFDEF POWERPC}
var
stkcookie: string;
@ -1343,7 +1386,7 @@ implementation
write_persistent_type_info(current_module.localsymtable);
{ Tables }
insertThreadVars;
InsertThreadvars;
{ Resource strings }
GenerateResourceStrings;
@ -2329,11 +2372,11 @@ implementation
InsertWideInits;
{ insert Tables and StackLength }
insertinitfinaltable;
InsertInitFinalTable;
InsertThreadvarTablesTable;
InsertResourceTablesTable;
InsertWideInitsTablesTable;
insertmemorysizes;
InsertMemorySizes;
{ Insert symbol to resource info }
InsertResourceInfo(resources_used);

47
compiler/ppu.pas
View File

@ -135,30 +135,29 @@ const
iblinkotherframeworks = 100;
{ unit flags }
uf_init = $1;
uf_finalize = $2;
uf_big_endian = $4;
// uf_has_browser = $10;
uf_in_library = $20; { is the file in another file than <ppufile>.* ? }
uf_smart_linked = $40; { the ppu can be smartlinked }
uf_static_linked = $80; { the ppu can be linked static }
uf_shared_linked = $100; { the ppu can be linked shared }
// uf_local_browser = $200;
uf_no_link = $400; { unit has no .o generated, but can still have
external linking! }
uf_has_resourcestrings = $800; { unit has resource string section }
uf_little_endian = $1000;
uf_release = $2000; { unit was compiled with -Ur option }
uf_threadvars = $4000; { unit has threadvars }
uf_fpu_emulation = $8000; { this unit was compiled with fpu emulation on }
uf_has_stabs_debuginfo = $10000; { this unit has stabs debuginfo generated }
uf_local_symtable = $20000; { this unit has a local symtable stored }
uf_uses_variants = $40000; { this unit uses variants }
uf_has_resourcefiles = $80000; { this unit has external resources (using $R directive)}
uf_has_exports = $100000; { this module or a used unit has exports }
uf_has_dwarf_debuginfo = $200000; { this unit has dwarf debuginfo generated }
uf_wideinits = $400000; { this unit has winlike widestring typed constants }
uf_init = $000001; { unit has initialization section }
uf_finalize = $000002; { unit has finalization section }
uf_big_endian = $000004;
//uf_has_browser = $000010;
uf_in_library = $000020; { is the file in another file than <ppufile>.* ? }
uf_smart_linked = $000040; { the ppu can be smartlinked }
uf_static_linked = $000080; { the ppu can be linked static }
uf_shared_linked = $000100; { the ppu can be linked shared }
//uf_local_browser = $000200;
uf_no_link = $000400; { unit has no .o generated, but can still have external linking! }
uf_has_resourcestrings = $000800; { unit has resource string section }
uf_little_endian = $001000;
uf_release = $002000; { unit was compiled with -Ur option }
uf_threadvars = $004000; { unit has threadvars }
uf_fpu_emulation = $008000; { this unit was compiled with fpu emulation on }
uf_has_stabs_debuginfo = $010000; { this unit has stabs debuginfo generated }
uf_local_symtable = $020000; { this unit has a local symtable stored }
uf_uses_variants = $040000; { this unit uses variants }
uf_has_resourcefiles = $080000; { this unit has external resources (using $R directive)}
uf_has_exports = $100000; { this module or a used unit has exports }
uf_has_dwarf_debuginfo = $200000; { this unit has dwarf debuginfo generated }
uf_wideinits = $400000; { this unit has winlike widestring typed constants }
uf_classinits = $800000; { this unit has class constructors/destructors }
type
{ bestreal is defined based on the target architecture }

2
compiler/psub.pas
View File

@ -490,7 +490,7 @@ implementation
{ why (JM) }
oldlocalswitches:=current_settings.localswitches;
current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range];
pd:=current_objectdef.Finddestructor;
pd:=current_objectdef.find_destructor;
if assigned(pd) then
begin
{ if vmt<>0 then call destructor }

57
compiler/symdef.pas
View File

@ -293,14 +293,15 @@ interface
{ this should be called when this class implements an interface }
procedure prepareguid;
function is_publishable : boolean;override;
function is_related(d : tdef) : boolean;override;
function needs_inittable : boolean;override;
function rtti_mangledname(rt:trttitype):string;override;
function vmt_mangledname : string;
procedure check_forwards;
function is_related(d : tdef) : boolean;override;
procedure insertvmt;
procedure set_parent(c : tobjectdef);
function FindDestructor : tprocdef;
function find_procdef_bytype(pt:tproctypeoption): tprocdef;
function find_destructor: tprocdef;
function implements_any_interfaces: boolean;
procedure reset; override;
{ dispinterface support }
@ -3299,7 +3300,8 @@ implementation
if assigned(_class) then
begin
s:=_class.RttiName+'.';
if (po_classmethod in procoptions) then
if (po_classmethod in procoptions) and
not (proctypeoption in [potype_class_constructor,potype_class_destructor]) then
s:='class ' + s;
end;
if owner.symtabletype=localsymtable then
@ -3333,7 +3335,8 @@ implementation
{ forced calling convention? }
if (po_hascallingconvention in procoptions) then
s:=s+' '+ProcCallOptionStr[proccalloption]+';';
if po_staticmethod in procoptions then
if (po_staticmethod in procoptions) and
not (proctypeoption in [potype_class_constructor,potype_class_destructor]) then
s:=s+' Static;';
fullprocname:=s;
end;
@ -4398,33 +4401,37 @@ implementation
is_related:=false;
end;
function tobjectdef.FindDestructor : tprocdef;
function tobjectdef.find_procdef_bytype(pt:tproctypeoption): tprocdef;
var
objdef : tobjectdef;
i : longint;
sym : tsym;
pd : tprocdef;
i: longint;
sym: tsym;
begin
for i:=0 to symtable.SymList.Count-1 do
begin
sym:=tsym(symtable.SymList[i]);
if sym.typ=procsym then
begin
result:=tprocsym(sym).find_procdef_bytype(pt);
if assigned(result) then
exit;
end;
end;
result:=nil;
end;
function tobjectdef.find_destructor: tprocdef;
var
objdef: tobjectdef;
begin
result:=nil;
objdef:=self;
while assigned(objdef) do
begin
for i:=0 to objdef.symtable.SymList.Count-1 do
begin
sym:=TSym(objdef.symtable.SymList[i]);
if sym.typ=procsym then
begin
pd:=Tprocsym(sym).Find_procdef_bytype(potype_destructor);
if assigned(pd) then
begin
result:=pd;
exit;
end;
end;
end;
objdef:=objdef.childof;
result:=find_procdef_bytype(potype_destructor);
if assigned(result) then
exit;
objdef:=objdef.childof;
end;
result:=nil;
end;
function tobjectdef.implements_any_interfaces: boolean;