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

* defer codegeneration for nested procedures

Browse Source
This commit is contained in:
peter 2003-05-22 21:31:35 +00:00
parent 31286d02e6
commit 345228fd29
4 changed files with 497 additions and 417 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

161
compiler/pdecsub.pas
View File

@ -29,15 +29,17 @@ interface
uses uses
tokens,symconst,symtype,symdef,symsym; tokens,symconst,symtype,symdef,symsym;
const type
pd_global = $1; { directive must be global } tpdflag=(
pd_body = $2; { directive needs a body } pd_body, { directive needs a body }
pd_implemen = $4; { directive can be used implementation section } pd_implemen, { directive can be used implementation section }
pd_interface = $8; { directive can be used interface section } pd_interface, { directive can be used interface section }
pd_object = $10; { directive can be used object declaration } pd_object, { directive can be used object declaration }
pd_procvar = $20; { directive can be used procvar declaration } pd_procvar, { directive can be used procvar declaration }
pd_notobject = $40; { directive can not be used object declaration } pd_notobject, { directive can not be used object declaration }
pd_notobjintf= $80; { directive can not be used interface declaration } pd_notobjintf { directive can not be used interface declaration }
);
tpdflags=set of tpdflag;
function is_proc_directive(tok:ttoken):boolean; function is_proc_directive(tok:ttoken):boolean;
@ -50,7 +52,7 @@ interface
procedure handle_calling_convention(pd:tabstractprocdef); procedure handle_calling_convention(pd:tabstractprocdef);
procedure parse_parameter_dec(pd:tabstractprocdef); procedure parse_parameter_dec(pd:tabstractprocdef);
procedure parse_proc_directives(pd:tabstractprocdef;var pdflags:word); procedure parse_proc_directives(pd:tabstractprocdef;var pdflags:tpdflags);
procedure parse_var_proc_directives(sym:tsym); procedure parse_var_proc_directives(sym:tsym);
procedure parse_object_proc_directives(pd:tabstractprocdef); procedure parse_object_proc_directives(pd:tabstractprocdef);
function parse_proc_head(aclass:tobjectdef;potype:tproctypeoption):tprocdef; function parse_proc_head(aclass:tobjectdef;potype:tproctypeoption):tprocdef;
@ -341,7 +343,6 @@ implementation
srsym : tsym; srsym : tsym;
hs1 : string; hs1 : string;
varspez : Tvarspez; varspez : Tvarspez;
hpara : tparaitem;
tdefaultvalue : tconstsym; tdefaultvalue : tconstsym;
defaultrequired : boolean; defaultrequired : boolean;
old_object_option : tsymoptions; old_object_option : tsymoptions;
@ -484,7 +485,7 @@ implementation
paramanager.push_addr_param(tt.def,pd.proccalloption) then paramanager.push_addr_param(tt.def,pd.proccalloption) then
include(vs.varoptions,vo_regable); include(vs.varoptions,vo_regable);
end; end;
hpara:=pd.concatpara(nil,tt,vs,tdefaultvalue,false); pd.concatpara(nil,tt,vs,tdefaultvalue,false);
vs:=tvarsym(vs.listnext); vs:=tvarsym(vs.listnext);
end; end;
until not try_to_consume(_SEMICOLON); until not try_to_consume(_SEMICOLON);
@ -588,9 +589,6 @@ implementation
begin begin
aclass:=tobjectdef(ttypesym(sym).restype.def); aclass:=tobjectdef(ttypesym(sym).restype.def);
aprocsym:=tprocsym(aclass.symtable.search(sp)); aprocsym:=tprocsym(aclass.symtable.search(sp));
{ The procedure has been found. So it is
a global one. Set the flags to mark this.}
include(current_procinfo.flags,pi_is_global);
{ we solve this below } { we solve this below }
if assigned(aprocsym) then if assigned(aprocsym) then
begin begin
@ -695,13 +693,6 @@ implementation
else else
aprocsym:=tprocsym.create(orgsp); aprocsym:=tprocsym.create(orgsp);
symtablestack.insert(aprocsym); symtablestack.insert(aprocsym);
end
else
begin
{ Set global flag when found in globalsytmable }
if (not parse_only) and
(aprocsym.owner.symtabletype=globalsymtable) then
include(current_procinfo.flags,pi_is_global);
end; end;
{ to get the correct symtablelevel we must ignore objectsymtables } { to get the correct symtablelevel we must ignore objectsymtables }
@ -712,6 +703,10 @@ implementation
pd._class:=aclass; pd._class:=aclass;
pd.procsym:=aprocsym; pd.procsym:=aprocsym;
pd.proctypeoption:=potype; pd.proctypeoption:=potype;
{ methods need to be exported }
if assigned(aclass) and
(symtablestack.symtablelevel=main_program_level) then
include(pd.procoptions,po_public);
{ symbol options that need to be kept per procdef } { symbol options that need to be kept per procdef }
pd.fileinfo:=procstartfilepos; pd.fileinfo:=procstartfilepos;
@ -756,9 +751,6 @@ implementation
inc(testcurobject); inc(testcurobject);
single_type(pd.rettype,hs,false); single_type(pd.rettype,hs,false);
pd.test_if_fpu_result; pd.test_if_fpu_result;
if (pd.rettype.def.deftype=stringdef) and
(tstringdef(pd.rettype.def).string_typ<>st_shortstring) then
include(current_procinfo.flags,pi_needs_implicit_finally);
dec(testcurobject); dec(testcurobject);
end end
else else
@ -1174,7 +1166,7 @@ type
pd_handler=procedure(pd:tabstractprocdef); pd_handler=procedure(pd:tabstractprocdef);
proc_dir_rec=record proc_dir_rec=record
idtok : ttoken; idtok : ttoken;
pd_flags : longint; pd_flags : tpdflags;
handler : pd_handler; handler : pd_handler;
pocall : tproccalloption; pocall : tproccalloption;
pooption : tprocoptions; pooption : tprocoptions;
@ -1189,7 +1181,7 @@ const
( (
( (
idtok:_ABSTRACT; idtok:_ABSTRACT;
pd_flags : pd_interface+pd_object+pd_notobjintf; pd_flags : [pd_interface,pd_object,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_abstract; handler : {$ifdef FPCPROCVAR}@{$endif}pd_abstract;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_abstractmethod]; pooption : [po_abstractmethod];
@ -1198,7 +1190,7 @@ const
mutexclpo : [po_exports,po_interrupt,po_external] mutexclpo : [po_exports,po_interrupt,po_external]
),( ),(
idtok:_ALIAS; idtok:_ALIAS;
pd_flags : pd_implemen+pd_body+pd_notobjintf; pd_flags : [pd_implemen,pd_body,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_alias; handler : {$ifdef FPCPROCVAR}@{$endif}pd_alias;
pocall : pocall_none; pocall : pocall_none;
pooption : []; pooption : [];
@ -1207,7 +1199,7 @@ const
mutexclpo : [po_external] mutexclpo : [po_external]
),( ),(
idtok:_ASMNAME; idtok:_ASMNAME;
pd_flags : pd_interface+pd_implemen+pd_notobjintf; pd_flags : [pd_interface,pd_implemen,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_asmname; handler : {$ifdef FPCPROCVAR}@{$endif}pd_asmname;
pocall : pocall_cdecl; pocall : pocall_cdecl;
pooption : [po_external]; pooption : [po_external];
@ -1216,7 +1208,7 @@ const
mutexclpo : [po_external] mutexclpo : [po_external]
),( ),(
idtok:_ASSEMBLER; idtok:_ASSEMBLER;
pd_flags : pd_implemen+pd_body+pd_notobjintf; pd_flags : [pd_implemen,pd_body,pd_notobjintf];
handler : nil; handler : nil;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_assembler]; pooption : [po_assembler];
@ -1225,7 +1217,7 @@ const
mutexclpo : [po_external] mutexclpo : [po_external]
),( ),(
idtok:_CDECL; idtok:_CDECL;
pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar; pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
handler : nil; handler : nil;
pocall : pocall_cdecl; pocall : pocall_cdecl;
pooption : []; pooption : [];
@ -1234,7 +1226,7 @@ const
mutexclpo : [po_assembler,po_external] mutexclpo : [po_assembler,po_external]
),( ),(
idtok:_DYNAMIC; idtok:_DYNAMIC;
pd_flags : pd_interface+pd_object+pd_notobjintf; pd_flags : [pd_interface,pd_object,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_virtual; handler : {$ifdef FPCPROCVAR}@{$endif}pd_virtual;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_virtualmethod]; pooption : [po_virtualmethod];
@ -1243,16 +1235,16 @@ const
mutexclpo : [po_exports,po_interrupt,po_external] mutexclpo : [po_exports,po_interrupt,po_external]
),( ),(
idtok:_EXPORT; idtok:_EXPORT;
pd_flags : pd_body+pd_global+pd_interface+pd_implemen{??}+pd_notobjintf; pd_flags : [pd_body,pd_interface,pd_implemen,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_export; handler : {$ifdef FPCPROCVAR}@{$endif}pd_export;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_exports]; pooption : [po_exports,po_public];
mutexclpocall : [pocall_internproc,pocall_inline]; mutexclpocall : [pocall_internproc,pocall_inline];
mutexclpotype : [potype_constructor,potype_destructor]; mutexclpotype : [potype_constructor,potype_destructor];
mutexclpo : [po_external,po_interrupt] mutexclpo : [po_external,po_interrupt]
),( ),(
idtok:_EXTERNAL; idtok:_EXTERNAL;
pd_flags : pd_implemen+pd_interface+pd_notobject+pd_notobjintf; pd_flags : [pd_implemen,pd_interface,pd_notobject,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_external; handler : {$ifdef FPCPROCVAR}@{$endif}pd_external;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_external]; pooption : [po_external];
@ -1261,7 +1253,7 @@ const
mutexclpo : [po_exports,po_interrupt,po_assembler] mutexclpo : [po_exports,po_interrupt,po_assembler]
),( ),(
idtok:_FAR; idtok:_FAR;
pd_flags : pd_implemen+pd_body+pd_interface+pd_procvar+pd_notobject+pd_notobjintf; pd_flags : [pd_implemen,pd_body,pd_interface,pd_procvar,pd_notobject,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_far; handler : {$ifdef FPCPROCVAR}@{$endif}pd_far;
pocall : pocall_none; pocall : pocall_none;
pooption : []; pooption : [];
@ -1270,7 +1262,7 @@ const
mutexclpo : [] mutexclpo : []
),( ),(
idtok:_FAR16; idtok:_FAR16;
pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar+pd_notobject; pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar,pd_notobject];
handler : nil; handler : nil;
pocall : pocall_far16; pocall : pocall_far16;
pooption : []; pooption : [];
@ -1279,7 +1271,7 @@ const
mutexclpo : [po_external,po_leftright] mutexclpo : [po_external,po_leftright]
),( ),(
idtok:_FORWARD; idtok:_FORWARD;
pd_flags : pd_implemen+pd_notobject+pd_notobjintf; pd_flags : [pd_implemen,pd_notobject,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_forward; handler : {$ifdef FPCPROCVAR}@{$endif}pd_forward;
pocall : pocall_none; pocall : pocall_none;
pooption : []; pooption : [];
@ -1288,7 +1280,7 @@ const
mutexclpo : [po_external] mutexclpo : [po_external]
),( ),(
idtok:_FPCCALL; idtok:_FPCCALL;
pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar; pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
handler : nil; handler : nil;
pocall : pocall_fpccall; pocall : pocall_fpccall;
pooption : []; pooption : [];
@ -1297,7 +1289,7 @@ const
mutexclpo : [po_leftright] mutexclpo : [po_leftright]
),( ),(
idtok:_INLINE; idtok:_INLINE;
pd_flags : pd_interface+pd_implemen+pd_body+pd_notobjintf; pd_flags : [pd_interface,pd_implemen,pd_body,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_inline; handler : {$ifdef FPCPROCVAR}@{$endif}pd_inline;
pocall : pocall_inline; pocall : pocall_inline;
pooption : []; pooption : [];
@ -1306,7 +1298,7 @@ const
mutexclpo : [po_exports,po_external,po_interrupt] mutexclpo : [po_exports,po_external,po_interrupt]
),( ),(
idtok:_INTERNCONST; idtok:_INTERNCONST;
pd_flags : pd_implemen+pd_body+pd_notobject+pd_notobjintf; pd_flags : [pd_implemen,pd_body,pd_notobject,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_intern; handler : {$ifdef FPCPROCVAR}@{$endif}pd_intern;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_internconst]; pooption : [po_internconst];
@ -1315,7 +1307,7 @@ const
mutexclpo : [] mutexclpo : []
),( ),(
idtok:_INTERNPROC; idtok:_INTERNPROC;
pd_flags : pd_implemen+pd_notobject+pd_notobjintf; pd_flags : [pd_implemen,pd_notobject,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_intern; handler : {$ifdef FPCPROCVAR}@{$endif}pd_intern;
pocall : pocall_internproc; pocall : pocall_internproc;
pooption : []; pooption : [];
@ -1324,7 +1316,7 @@ const
mutexclpo : [po_exports,po_external,po_interrupt,po_assembler,po_iocheck,po_leftright] mutexclpo : [po_exports,po_external,po_interrupt,po_assembler,po_iocheck,po_leftright]
),( ),(
idtok:_INTERRUPT; idtok:_INTERRUPT;
pd_flags : pd_implemen+pd_body+pd_notobject+pd_notobjintf; pd_flags : [pd_implemen,pd_body,pd_notobject,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_interrupt; handler : {$ifdef FPCPROCVAR}@{$endif}pd_interrupt;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_interrupt]; pooption : [po_interrupt];
@ -1334,7 +1326,7 @@ const
mutexclpo : [po_external,po_leftright,po_clearstack] mutexclpo : [po_external,po_leftright,po_clearstack]
),( ),(
idtok:_IOCHECK; idtok:_IOCHECK;
pd_flags : pd_implemen+pd_body+pd_notobjintf; pd_flags : [pd_implemen,pd_body,pd_notobjintf];
handler : nil; handler : nil;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_iocheck]; pooption : [po_iocheck];
@ -1343,7 +1335,7 @@ const
mutexclpo : [po_external] mutexclpo : [po_external]
),( ),(
idtok:_MESSAGE; idtok:_MESSAGE;
pd_flags : pd_interface+pd_object+pd_notobjintf; pd_flags : [pd_interface,pd_object,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_message; handler : {$ifdef FPCPROCVAR}@{$endif}pd_message;
pocall : pocall_none; pocall : pocall_none;
pooption : []; { can be po_msgstr or po_msgint } pooption : []; { can be po_msgstr or po_msgint }
@ -1352,7 +1344,7 @@ const
mutexclpo : [po_interrupt,po_external] mutexclpo : [po_interrupt,po_external]
),( ),(
idtok:_NEAR; idtok:_NEAR;
pd_flags : pd_implemen+pd_body+pd_procvar+pd_notobjintf; pd_flags : [pd_implemen,pd_body,pd_procvar,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_near; handler : {$ifdef FPCPROCVAR}@{$endif}pd_near;
pocall : pocall_none; pocall : pocall_none;
pooption : []; pooption : [];
@ -1361,7 +1353,7 @@ const
mutexclpo : [] mutexclpo : []
),( ),(
idtok:_OVERLOAD; idtok:_OVERLOAD;
pd_flags : pd_implemen+pd_interface+pd_body; pd_flags : [pd_implemen,pd_interface,pd_body];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_overload; handler : {$ifdef FPCPROCVAR}@{$endif}pd_overload;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_overload]; pooption : [po_overload];
@ -1370,7 +1362,7 @@ const
mutexclpo : [] mutexclpo : []
),( ),(
idtok:_OVERRIDE; idtok:_OVERRIDE;
pd_flags : pd_interface+pd_object+pd_notobjintf; pd_flags : [pd_interface,pd_object,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_override; handler : {$ifdef FPCPROCVAR}@{$endif}pd_override;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_overridingmethod,po_virtualmethod]; pooption : [po_overridingmethod,po_virtualmethod];
@ -1379,7 +1371,7 @@ const
mutexclpo : [po_exports,po_external,po_interrupt] mutexclpo : [po_exports,po_external,po_interrupt]
),( ),(
idtok:_PASCAL; idtok:_PASCAL;
pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar; pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
handler : nil; handler : nil;
pocall : pocall_pascal; pocall : pocall_pascal;
pooption : []; pooption : [];
@ -1388,7 +1380,7 @@ const
mutexclpo : [po_external] mutexclpo : [po_external]
),( ),(
idtok:_POPSTACK; idtok:_POPSTACK;
pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar; pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
handler : nil; handler : nil;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_clearstack]; pooption : [po_clearstack];
@ -1397,16 +1389,16 @@ const
mutexclpo : [po_assembler,po_external] mutexclpo : [po_assembler,po_external]
),( ),(
idtok:_PUBLIC; idtok:_PUBLIC;
pd_flags : pd_implemen+pd_body+pd_global+pd_notobject+pd_notobjintf; pd_flags : [pd_implemen,pd_body,pd_notobject,pd_notobjintf];
handler : nil; handler : nil;
pocall : pocall_none; pocall : pocall_none;
pooption : []; pooption : [po_public];
mutexclpocall : [pocall_internproc,pocall_inline]; mutexclpocall : [pocall_internproc,pocall_inline];
mutexclpotype : []; mutexclpotype : [];
mutexclpo : [po_external] mutexclpo : [po_external]
),( ),(
idtok:_REGISTER; idtok:_REGISTER;
pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar; pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
handler : nil; handler : nil;
pocall : pocall_register; pocall : pocall_register;
pooption : []; pooption : [];
@ -1415,7 +1407,7 @@ const
mutexclpo : [po_external] mutexclpo : [po_external]
),( ),(
idtok:_REINTRODUCE; idtok:_REINTRODUCE;
pd_flags : pd_interface+pd_object; pd_flags : [pd_interface,pd_object];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_reintroduce; handler : {$ifdef FPCPROCVAR}@{$endif}pd_reintroduce;
pocall : pocall_none; pocall : pocall_none;
pooption : []; pooption : [];
@ -1424,7 +1416,7 @@ const
mutexclpo : [] mutexclpo : []
),( ),(
idtok:_SAFECALL; idtok:_SAFECALL;
pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar; pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
handler : nil; handler : nil;
pocall : pocall_safecall; pocall : pocall_safecall;
pooption : []; pooption : [];
@ -1433,7 +1425,7 @@ const
mutexclpo : [po_external] mutexclpo : [po_external]
),( ),(
idtok:_SAVEREGISTERS; idtok:_SAVEREGISTERS;
pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar+pd_notobjintf; pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar,pd_notobjintf];
handler : nil; handler : nil;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_saveregisters]; pooption : [po_saveregisters];
@ -1442,7 +1434,7 @@ const
mutexclpo : [po_external] mutexclpo : [po_external]
),( ),(
idtok:_STATIC; idtok:_STATIC;
pd_flags : pd_interface+pd_object+pd_notobjintf; pd_flags : [pd_interface,pd_object,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_static; handler : {$ifdef FPCPROCVAR}@{$endif}pd_static;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_staticmethod]; pooption : [po_staticmethod];
@ -1451,7 +1443,7 @@ const
mutexclpo : [po_external,po_interrupt,po_exports] mutexclpo : [po_external,po_interrupt,po_exports]
),( ),(
idtok:_STDCALL; idtok:_STDCALL;
pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar; pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
handler : nil; handler : nil;
pocall : pocall_stdcall; pocall : pocall_stdcall;
pooption : []; pooption : [];
@ -1460,7 +1452,7 @@ const
mutexclpo : [po_external] mutexclpo : [po_external]
),( ),(
idtok:_SYSCALL; idtok:_SYSCALL;
pd_flags : pd_interface+pd_implemen+pd_notobjintf; pd_flags : [pd_interface,pd_implemen,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_syscall; handler : {$ifdef FPCPROCVAR}@{$endif}pd_syscall;
pocall : pocall_palmossyscall; pocall : pocall_palmossyscall;
pooption : []; pooption : [];
@ -1469,7 +1461,7 @@ const
mutexclpo : [po_external,po_assembler,po_interrupt,po_exports] mutexclpo : [po_external,po_assembler,po_interrupt,po_exports]
),( ),(
idtok:_VIRTUAL; idtok:_VIRTUAL;
pd_flags : pd_interface+pd_object+pd_notobjintf; pd_flags : [pd_interface,pd_object,pd_notobjintf];
handler : {$ifdef FPCPROCVAR}@{$endif}pd_virtual; handler : {$ifdef FPCPROCVAR}@{$endif}pd_virtual;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_virtualmethod]; pooption : [po_virtualmethod];
@ -1478,7 +1470,7 @@ const
mutexclpo : [po_external,po_interrupt,po_exports] mutexclpo : [po_external,po_interrupt,po_exports]
),( ),(
idtok:_CPPDECL; idtok:_CPPDECL;
pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar; pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
handler : nil; handler : nil;
pocall : pocall_cppdecl; pocall : pocall_cppdecl;
pooption : [po_savestdregs]; pooption : [po_savestdregs];
@ -1487,7 +1479,7 @@ const
mutexclpo : [po_assembler,po_external,po_virtualmethod] mutexclpo : [po_assembler,po_external,po_virtualmethod]
),( ),(
idtok:_VARARGS; idtok:_VARARGS;
pd_flags : pd_interface+pd_implemen+pd_procvar; pd_flags : [pd_interface,pd_implemen,pd_procvar];
handler : nil; handler : nil;
pocall : pocall_none; pocall : pocall_none;
pooption : [po_varargs]; pooption : [po_varargs];
@ -1497,7 +1489,7 @@ const
mutexclpo : [po_assembler,po_interrupt,po_leftright] mutexclpo : [po_assembler,po_interrupt,po_leftright]
),( ),(
idtok:_COMPILERPROC; idtok:_COMPILERPROC;
pd_flags : pd_interface+pd_implemen+pd_body+pd_notobjintf; pd_flags : [pd_interface,pd_implemen,pd_body,pd_notobjintf];
handler : nil; handler : nil;
pocall : pocall_compilerproc; pocall : pocall_compilerproc;
pooption : []; pooption : [];
@ -1522,7 +1514,7 @@ const
end; end;
function parse_proc_direc(pd:tabstractprocdef;var pdflags:word):boolean; function parse_proc_direc(pd:tabstractprocdef;var pdflags:tpdflags):boolean;
{ {
Parse the procedure directive, returns true if a correct directive is found Parse the procedure directive, returns true if a correct directive is found
} }
@ -1560,7 +1552,7 @@ const
begin begin
{ parsing a procvar type the name can be any { parsing a procvar type the name can be any
next variable !! } next variable !! }
if (pdflags and (pd_procvar or pd_object))=0 then if (pdflags * [pd_procvar,pd_object])=[] then
Message1(parser_w_unknown_proc_directive_ignored,name); Message1(parser_w_unknown_proc_directive_ignored,name);
exit; exit;
end; end;
@ -1592,19 +1584,19 @@ const
{ check if method and directive not for object, like public. { check if method and directive not for object, like public.
This needs to be checked also for procvars } This needs to be checked also for procvars }
if ((proc_direcdata[p].pd_flags and pd_notobject)<>0) and if (pd_notobject in proc_direcdata[p].pd_flags) and
(pd.owner.symtabletype=objectsymtable) then (pd.owner.symtabletype=objectsymtable) then
exit; exit;
if pd.deftype=procdef then if pd.deftype=procdef then
begin begin
{ Check if the directive is only for objects } { Check if the directive is only for objects }
if ((proc_direcdata[p].pd_flags and pd_object)<>0) and if (pd_object in proc_direcdata[p].pd_flags) and
not assigned(tprocdef(pd)._class) then not assigned(tprocdef(pd)._class) then
exit; exit;
{ check if method and directive not for interface } { check if method and directive not for interface }
if ((proc_direcdata[p].pd_flags and pd_notobjintf)<>0) and if (pd_notobjintf in proc_direcdata[p].pd_flags) and
is_interface(tprocdef(pd)._class) then is_interface(tprocdef(pd)._class) then
exit; exit;
end; end;
@ -1614,30 +1606,28 @@ const
parse_proc_direc:=true; parse_proc_direc:=true;
{ Check the pd_flags if the directive should be allowed } { Check the pd_flags if the directive should be allowed }
if ((pdflags and pd_interface)<>0) and if (pd_interface in pdflags) and
((proc_direcdata[p].pd_flags and pd_interface)=0) then not(pd_interface in proc_direcdata[p].pd_flags) then
begin begin
Message1(parser_e_proc_dir_not_allowed_in_interface,name); Message1(parser_e_proc_dir_not_allowed_in_interface,name);
exit; exit;
end; end;
if ((pdflags and pd_implemen)<>0) and if (pd_implemen in pdflags) and
((proc_direcdata[p].pd_flags and pd_implemen)=0) then not(pd_implemen in proc_direcdata[p].pd_flags) then
begin begin
Message1(parser_e_proc_dir_not_allowed_in_implementation,name); Message1(parser_e_proc_dir_not_allowed_in_implementation,name);
exit; exit;
end; end;
if ((pdflags and pd_procvar)<>0) and if (pd_procvar in pdflags) and
((proc_direcdata[p].pd_flags and pd_procvar)=0) then not(pd_procvar in proc_direcdata[p].pd_flags) then
begin begin
Message1(parser_e_proc_dir_not_allowed_in_procvar,name); Message1(parser_e_proc_dir_not_allowed_in_procvar,name);
exit; exit;
end; end;
{ Return the new pd_flags } { Return the new pd_flags }
if (proc_direcdata[p].pd_flags and pd_body)=0 then if not(pd_body in proc_direcdata[p].pd_flags) then
pdflags:=pdflags and (not pd_body); exclude(pdflags,pd_body);
if (proc_direcdata[p].pd_flags and pd_global)<>0 then
pdflags:=pdflags or pd_global;
{ Add the correct flag } { Add the correct flag }
pd.procoptions:=pd.procoptions+proc_direcdata[p].pooption; pd.procoptions:=pd.procoptions+proc_direcdata[p].pooption;
@ -1826,7 +1816,7 @@ const
procedure parse_proc_directives(pd:tabstractprocdef;var pdflags:word); procedure parse_proc_directives(pd:tabstractprocdef;var pdflags:tpdflags);
{ {
Parse the procedure directives. It does not matter if procedure directives Parse the procedure directives. It does not matter if procedure directives
are written using ;procdir; or ['procdir'] syntax. are written using ;procdir; or ['procdir'] syntax.
@ -1870,10 +1860,10 @@ const
procedure parse_var_proc_directives(sym:tsym); procedure parse_var_proc_directives(sym:tsym);
var var
pdflags : word; pdflags : tpdflags;
pd : tabstractprocdef; pd : tabstractprocdef;
begin begin
pdflags:=pd_procvar; pdflags:=[pd_procvar];
pd:=nil; pd:=nil;
case sym.typ of case sym.typ of
varsym : varsym :
@ -1894,9 +1884,9 @@ const
procedure parse_object_proc_directives(pd:tabstractprocdef); procedure parse_object_proc_directives(pd:tabstractprocdef);
var var
pdflags : word; pdflags : tpdflags;
begin begin
pdflags:=pd_object; pdflags:=[pd_object];
parse_proc_directives(pd,pdflags); parse_proc_directives(pd,pdflags);
end; end;
@ -2173,7 +2163,10 @@ const
end. end.
{ {
$Log$ $Log$
Revision 1.124 2003-05-15 18:58:53 peter Revision 1.125 2003-05-22 21:31:35 peter
* defer codegeneration for nested procedures
Revision 1.124 2003/05/15 18:58:53 peter
* removed selfpointer_offset, vmtpointer_offset * removed selfpointer_offset, vmtpointer_offset
* tvarsym.adjusted_address * tvarsym.adjusted_address
* address in localsymtable is now in the real direction * address in localsymtable is now in the real direction

33
compiler/pmodules.pas
View File

@ -725,6 +725,7 @@ implementation
inc(ps.refs); inc(ps.refs);
symtablestack.insert(ps); symtablestack.insert(ps);
pd:=tprocdef.create(main_program_level); pd:=tprocdef.create(main_program_level);
include(pd.procoptions,po_public);
pd.procsym:=ps; pd.procsym:=ps;
ps.addprocdef(pd); ps.addprocdef(pd);
{ restore symtable } { restore symtable }
@ -799,7 +800,7 @@ implementation
objectlibrary.getlabel(aktexitlabel); objectlibrary.getlabel(aktexitlabel);
objectlibrary.getlabel(aktexit2label); objectlibrary.getlabel(aktexit2label);
include(current_procinfo.flags,pi_do_call); include(current_procinfo.flags,pi_do_call);
genentrycode(list,true,0,parasize,nostackframe,false); genentrycode(list,0,parasize,nostackframe,false);
genexitcode(list,parasize,nostackframe,false); genexitcode(list,parasize,nostackframe,false);
list.convert_registers; list.convert_registers;
release_main_proc(pd); release_main_proc(pd);
@ -844,18 +845,15 @@ implementation
if token=_ID then if token=_ID then
begin begin
{ create filenames and unit name } { create filenames and unit name }
main_file := current_scanner.inputfile; main_file := current_scanner.inputfile;
while assigned(main_file.next) do while assigned(main_file.next) do
main_file := main_file.next; main_file := main_file.next;
current_module.SetFileName(main_file.path^+main_file.name^,true); current_module.SetFileName(main_file.path^+main_file.name^,true);
current_module.SetModuleName(orgpattern);
stringdispose(current_module.modulename); { check for system unit }
stringdispose(current_module.realmodulename);
current_module.modulename:=stringdup(pattern);
current_module.realmodulename:=stringdup(orgpattern);
{ check for system unit }
new(s2); new(s2);
s2^:=upper(SplitName(main_file.name^)); s2^:=upper(SplitName(main_file.name^));
if (cs_check_unit_name in aktglobalswitches) and if (cs_check_unit_name in aktglobalswitches) and
@ -1040,7 +1038,9 @@ implementation
{ Compile the unit } { Compile the unit }
pd:=create_main_proc(current_module.modulename^+'_init',potype_unitinit,st); pd:=create_main_proc(current_module.modulename^+'_init',potype_unitinit,st);
pd.aliasnames.insert('INIT$$'+current_module.modulename^); pd.aliasnames.insert('INIT$$'+current_module.modulename^);
compile_proc_body(pd,true,false); tcgprocinfo(current_procinfo).parse_body;
tcgprocinfo(current_procinfo).generate_code;
tcgprocinfo(current_procinfo).resetprocdef;
release_main_proc(pd); release_main_proc(pd);
{ if the unit contains ansi/widestrings, initialization and { if the unit contains ansi/widestrings, initialization and
@ -1064,7 +1064,9 @@ implementation
{ Compile the finalize } { Compile the finalize }
pd:=create_main_proc(current_module.modulename^+'_finalize',potype_unitfinalize,st); pd:=create_main_proc(current_module.modulename^+'_finalize',potype_unitfinalize,st);
pd.aliasnames.insert('FINALIZE$$'+current_module.modulename^); pd.aliasnames.insert('FINALIZE$$'+current_module.modulename^);
compile_proc_body(pd,true,false); tcgprocinfo(current_procinfo).parse_body;
tcgprocinfo(current_procinfo).generate_code;
tcgprocinfo(current_procinfo).resetprocdef;
release_main_proc(pd); release_main_proc(pd);
end end
else if force_init_final then else if force_init_final then
@ -1352,7 +1354,9 @@ implementation
PROCEDURE main(ArgC:Integer;ArgV,EnvP:ARRAY OF PChar):Integer;CDECL; PROCEDURE main(ArgC:Integer;ArgV,EnvP:ARRAY OF PChar):Integer;CDECL;
So, all parameters are passerd into registers in sparc architecture.} So, all parameters are passerd into registers in sparc architecture.}
{$ENDIF SPARC} {$ENDIF SPARC}
compile_proc_body(pd,true,false); tcgprocinfo(current_procinfo).parse_body;
tcgprocinfo(current_procinfo).generate_code;
tcgprocinfo(current_procinfo).resetprocdef;
release_main_proc(pd); release_main_proc(pd);
{ should we force unit initialization? } { should we force unit initialization? }
@ -1390,7 +1394,9 @@ So, all parameters are passerd into registers in sparc architecture.}
{ Compile the finalize } { Compile the finalize }
pd:=create_main_proc(current_module.modulename^+'_finalize',potype_unitfinalize,st); pd:=create_main_proc(current_module.modulename^+'_finalize',potype_unitfinalize,st);
pd.aliasnames.insert('FINALIZE$$'+current_module.modulename^); pd.aliasnames.insert('FINALIZE$$'+current_module.modulename^);
compile_proc_body(pd,true,false); tcgprocinfo(current_procinfo).parse_body;
tcgprocinfo(current_procinfo).generate_code;
tcgprocinfo(current_procinfo).resetprocdef;
release_main_proc(pd); release_main_proc(pd);
end; end;
@ -1482,7 +1488,10 @@ So, all parameters are passerd into registers in sparc architecture.}
end. end.
{ {
$Log$ $Log$
Revision 1.106 2003-05-15 18:58:53 peter Revision 1.107 2003-05-22 21:31:35 peter
* defer codegeneration for nested procedures
Revision 1.106 2003/05/15 18:58:53 peter
* removed selfpointer_offset, vmtpointer_offset * removed selfpointer_offset, vmtpointer_offset
* tvarsym.adjusted_address * tvarsym.adjusted_address
* address in localsymtable is now in the real direction * address in localsymtable is now in the real direction

712
compiler/psub.pas
View File

@ -27,12 +27,27 @@ unit psub;
interface interface
uses uses
symdef; cclasses,
node,
symdef,cgbase;
type
tcgprocinfo=class(tprocinfo)
{ code for the subroutine as tree }
code : tnode;
nestedprocs : tlinkedlist;
constructor create(aparent:tprocinfo);override;
destructor destroy;override;
procedure generate_code;
procedure resetprocdef;
procedure add_to_symtablestack;
procedure remove_from_symtablestack;
procedure parse_body;
end;
procedure printnode_reset; procedure printnode_reset;
procedure compile_proc_body(pd:tprocdef;make_global,parent_has_class:boolean);
{ reads the declaration blocks } { reads the declaration blocks }
procedure read_declarations(islibrary : boolean); procedure read_declarations(islibrary : boolean);
@ -44,7 +59,7 @@ implementation
uses uses
{ common } { common }
cutils,cclasses, cutils,
{ global } { global }
globtype,globals,tokens,verbose,comphook, globtype,globals,tokens,verbose,comphook,
systems, systems,
@ -55,7 +70,6 @@ implementation
paramgr, paramgr,
ppu,fmodule, ppu,fmodule,
{ pass 1 } { pass 1 }
node,
nutils,nbas,nld,ncal,ncon,nflw,nadd,ncnv,nmem, nutils,nbas,nld,ncal,ncon,nflw,nadd,ncnv,nmem,
pass_1, pass_1,
{$ifdef state_tracking} {$ifdef state_tracking}
@ -69,7 +83,7 @@ implementation
scanner, scanner,
pbase,pstatmnt,pdecl,pdecsub,pexports, pbase,pstatmnt,pdecl,pdecsub,pexports,
{ codegen } { codegen }
tgobj,cgbase,rgobj,rgcpu, tgobj,rgobj,
ncgutil ncgutil
{$ifndef NOOPT} {$ifndef NOOPT}
{$ifdef i386} {$ifdef i386}
@ -80,7 +94,6 @@ implementation
{$endif} {$endif}
; ;
{**************************************************************************** {****************************************************************************
PROCEDURE/FUNCTION BODY PARSING PROCEDURE/FUNCTION BODY PARSING
****************************************************************************} ****************************************************************************}
@ -515,251 +528,204 @@ implementation
end; end;
procedure compile_proc_body(pd:tprocdef;make_global,parent_has_class:boolean); {****************************************************************************
{ TCGProcInfo
Compile the body of a procedure ****************************************************************************}
}
var constructor tcgprocinfo.create(aparent:tprocinfo);
oldexitlabel,oldexit2label : tasmlabel;
oldquickexitlabel:tasmlabel;
_class,hp:tobjectdef;
{ switches can change inside the procedure }
entryswitches, exitswitches : tlocalswitches;
oldaktmaxfpuregisters,localmaxfpuregisters : longint;
{ code for the subroutine as tree }
code:tnode;
{ true when no stackframe is required }
nostackframe:boolean;
{ number of bytes which have to be cleared by RET }
parasize:longint;
{ filepositions }
entrypos,
savepos,
exitpos : tfileposinfo;
oldprocdef : tprocdef;
begin begin
oldprocdef:=current_procdef; inherited Create(aparent);
current_procdef:=pd; nestedprocs:=tlinkedlist.create;
end;
{ calculate the lexical level }
if current_procdef.parast.symtablelevel>maxnesting then
Message(parser_e_too_much_lexlevel);
{ static is also important for local procedures !! } destructor tcgprocinfo.destroy;
if (po_staticmethod in current_procdef.procoptions) then begin
allow_only_static:=true inherited destroy;
else if (current_procdef.parast.symtablelevel=normal_function_level) then nestedprocs.free;
allow_only_static:=false; end;
{ save old labels }
oldexitlabel:=aktexitlabel;
oldexit2label:=aktexit2label;
oldquickexitlabel:=quickexitlabel;
{ get new labels }
objectlibrary.getlabel(aktexitlabel);
objectlibrary.getlabel(aktexit2label);
{ exit for fail in constructors }
if (current_procdef.proctypeoption=potype_constructor) then
objectlibrary.getlabel(quickexitlabel);
{ reset break and continue labels }
block_type:=bt_general;
aktbreaklabel:=nil;
aktcontinuelabel:=nil;
{$ifdef state_tracking}
{ aktstate:=Tstate_storage.create;}
{$endif state_tracking}
{ insert symtables for the class, but only if it is no nested function } procedure tcgprocinfo.generate_code;
if assigned(current_procdef._class) and not(parent_has_class) then var
begin oldprocdef : tprocdef;
{ insert them in the reverse order } oldprocinfo : tprocinfo;
hp:=nil; oldexitlabel,
repeat oldexit2label : tasmlabel;
_class:=current_procdef._class; oldaktmaxfpuregisters : longint;
while _class.childof<>hp do oldfilepos : tfileposinfo;
_class:=_class.childof; { true when no stackframe is required }
hp:=_class; nostackframe:boolean;
_class.symtable.next:=symtablestack; { number of bytes which have to be cleared by RET }
symtablestack:=_class.symtable; parasize:longint;
until hp=current_procdef._class; begin
end; { the initialization procedure can be empty, then we
don't need to generate anything. When it was an empty
procedure there would be at least a blocknode }
if not assigned(code) then
exit;
{ insert parasymtable in symtablestack when parsing oldprocinfo:=current_procinfo;
a function } oldprocdef:=current_procdef;
if current_procdef.parast.symtablelevel>=normal_function_level then oldfilepos:=aktfilepos;
begin oldaktmaxfpuregisters:=aktmaxfpuregisters;
current_procdef.parast.next:=symtablestack;
symtablestack:=current_procdef.parast;
end;
{ create a local symbol table for this routine }
if not assigned(current_procdef.localst) then
current_procdef.insert_localst;
{ insert localsymtable in symtablestack}
current_procdef.localst.next:=symtablestack;
symtablestack:=current_procdef.localst;
{ constant symbols are inserted in this symboltable }
constsymtable:=symtablestack;
{ reset the temporary memory } current_procinfo:=self;
rg.cleartempgen; current_procdef:=procdef;
rg.usedinproc:=[];
rg.usedbyproc:=[];
{ save entry info } { save old labels }
entrypos:=aktfilepos; oldexitlabel:=aktexitlabel;
entryswitches:=aktlocalswitches; oldexit2label:=aktexit2label;
localmaxfpuregisters:=aktmaxfpuregisters; { get new labels }
{ parse the code ... } objectlibrary.getlabel(aktexitlabel);
code:=block(current_module.islibrary); objectlibrary.getlabel(aktexit2label);
{ get a better entry point } aktbreaklabel:=nil;
if assigned(code) then aktcontinuelabel:=nil;
entrypos:=code.fileinfo;
{ save exit info }
exitswitches:=aktlocalswitches;
exitpos:=last_endtoken_filepos;
{ save current filepos }
savepos:=aktfilepos;
{ add implicit entry and exit code }
if assigned(code) then
add_entry_exit_code(code,entrypos,exitpos);
{ store a copy of the original tree for inline, for
normal procedures only store a reference to the
current tree }
if (current_procdef.proccalloption=pocall_inline) then
current_procdef.code:=code.getcopy
else
current_procdef.code:=code;
{When we are called to compile the body of a unit, aktprocsym should { add parast/localst to symtablestack }
point to the unit initialization. If the unit has no initialization, add_to_symtablestack;
aktprocsym=nil. But in that case code=nil. Thus we should check for
code=nil, when we use aktprocsym.}
{ set the start offset to the start of the temp area in the stack } { reset the temporary memory }
tg.setfirsttemp(current_procinfo.firsttemp_offset); rg.cleartempgen;
rg.usedinproc:=[];
rg.usedbyproc:=[];
{ ... and generate assembler } { set the start offset to the start of the temp area in the stack }
{ but set the right switches for entry !! } tg.setfirsttemp(current_procinfo.firsttemp_offset);
aktlocalswitches:=entryswitches;
oldaktmaxfpuregisters:=aktmaxfpuregisters;
aktmaxfpuregisters:=localmaxfpuregisters;
if assigned(code) then
begin
{ the procedure is now defined }
current_procdef.forwarddef:=false;
if paraprintnodetree=1 then generatecode(code);
printnode_procdef(current_procdef);
{ only generate the code if no type errors are found, else { first generate entry code with the correct position and switches }
finish at least the type checking pass } aktfilepos:=current_procinfo.entrypos;
{$ifndef NOPASS2} aktlocalswitches:=current_procinfo.entryswitches;
if (status.errorcount=0) then genentrycode(current_procinfo.aktentrycode,0,parasize,nostackframe,false);
begin
generatecode(code);
{ first generate entry code with the correct position and switches }
aktfilepos:=entrypos;
aktlocalswitches:=entryswitches;
genentrycode(current_procinfo.aktentrycode,make_global,0,parasize,nostackframe,false);
{ FPC_POPADDRSTACK destroys all registers (JM) } { now generate exit code with the correct position and switches }
if (pi_needs_implicit_finally in current_procinfo.flags) or aktfilepos:=current_procinfo.exitpos;
(pi_uses_exceptions in current_procinfo.flags) then aktlocalswitches:=current_procinfo.exitswitches;
begin genexitcode(current_procinfo.aktexitcode,parasize,nostackframe,false);
rg.usedinproc := ALL_REGISTERS;
end;
{ now generate exit code with the correct position and switches } { now all the registers used are known }
aktfilepos:=exitpos; current_procdef.usedintregisters:=rg.usedintinproc;
aktlocalswitches:=exitswitches; current_procdef.usedotherregisters:=rg.usedinproc;
genexitcode(current_procinfo.aktexitcode,parasize,nostackframe,false); current_procinfo.aktproccode.insertlist(current_procinfo.aktentrycode);
current_procinfo.aktproccode.concatlist(current_procinfo.aktexitcode);
{ now all the registers used are known }
current_procdef.usedintregisters:=rg.usedintinproc;
current_procdef.usedotherregisters:=rg.usedinproc;
current_procinfo.aktproccode.insertlist(current_procinfo.aktentrycode);
current_procinfo.aktproccode.concatlist(current_procinfo.aktexitcode);
{$ifdef newra} {$ifdef newra}
{ rg.writegraph;} { rg.writegraph;}
{$endif} {$endif}
if not(cs_no_regalloc in aktglobalswitches) then if not(cs_no_regalloc in aktglobalswitches) then
begin begin
{$ifdef newra} {$ifdef newra}
{Do register allocation.} {Do register allocation.}
repeat repeat
rg.prepare_colouring; rg.prepare_colouring;
rg.colour_registers; rg.colour_registers;
rg.epilogue_colouring; rg.epilogue_colouring;
{Are there spilled registers? We cannot do that yet.} {Are there spilled registers? We cannot do that yet.}
if rg.spillednodes<>'' then if rg.spillednodes<>'' then
internalerror(200304221); internalerror(200304221);
{if not try_fast_spill(rg) then {if not try_fast_spill(rg) then
slow_spill(rg); slow_spill(rg);
} }
until rg.spillednodes=''; until rg.spillednodes='';
current_procinfo.aktproccode.translate_registers(rg.colour); current_procinfo.aktproccode.translate_registers(rg.colour);
current_procinfo.aktproccode.convert_registers; current_procinfo.aktproccode.convert_registers;
{$else newra} {$else newra}
current_procinfo.aktproccode.convert_registers; current_procinfo.aktproccode.convert_registers;
{$ifndef NoOpt} {$ifndef NoOpt}
if (cs_optimize in aktglobalswitches) and if (cs_optimize in aktglobalswitches) and
{ do not optimize pure assembler procedures } { do not optimize pure assembler procedures }
not(pi_is_assembler in current_procinfo.flags) then not(pi_is_assembler in current_procinfo.flags) then
optimize(current_procinfo.aktproccode); optimize(current_procinfo.aktproccode);
{$endif NoOpt} {$endif NoOpt}
{$endif newra} {$endif newra}
end;
{ save local data (casetable) also in the same file }
if assigned(current_procinfo.aktlocaldata) and
(not current_procinfo.aktlocaldata.empty) then
begin
current_procinfo.aktproccode.concat(Tai_section.Create(sec_data));
current_procinfo.aktproccode.concatlist(current_procinfo.aktlocaldata);
current_procinfo.aktproccode.concat(Tai_section.Create(sec_code));
end;
{ add the procedure to the codesegment }
if (cs_create_smart in aktmoduleswitches) then
codeSegment.concat(Tai_cut.Create);
codeSegment.concatlist(current_procinfo.aktproccode);
end
else
do_resulttypepass(code);
{$else NOPASS2}
do_resulttypepass(code);
{$endif NOPASS2}
end; end;
{ ... remove symbol tables } { save local data (casetable) also in the same file }
if current_procdef.parast.symtablelevel>=normal_function_level then if assigned(current_procinfo.aktlocaldata) and
symtablestack:=symtablestack.next.next (not current_procinfo.aktlocaldata.empty) then
else begin
symtablestack:=symtablestack.next; current_procinfo.aktproccode.concat(Tai_section.Create(sec_data));
current_procinfo.aktproccode.concatlist(current_procinfo.aktlocaldata);
current_procinfo.aktproccode.concat(Tai_section.Create(sec_code));
end;
{ ... check for unused symbols } { add the procedure to the codesegment }
{ but only if there is no asm block } if (cs_create_smart in aktmoduleswitches) then
if assigned(code) then codeSegment.concat(Tai_cut.Create);
begin codeSegment.concatlist(current_procinfo.aktproccode);
if (Errorcount=0) then
begin
{ check if forwards are resolved }
tstoredsymtable(current_procdef.localst).check_forwards;
{ check if all labels are used }
tstoredsymtable(current_procdef.localst).checklabels;
{ remove cross unit overloads }
tstoredsymtable(current_procdef.localst).unchain_overloaded;
end;
if not(pi_uses_asm in current_procinfo.flags) then
begin
{ not for unit init, becuase the var can be used in finalize,
it will be done in proc_unit }
if not(current_procdef.proctypeoption
in [potype_proginit,potype_unitinit,potype_unitfinalize]) then
tstoredsymtable(current_procdef.localst).allsymbolsused;
tstoredsymtable(current_procdef.parast).allsymbolsused;
end;
end;
{ all registers can be used again }
rg.resetusableregisters;
{ only now we can remove the temps }
tg.resettempgen;
{ restore symtablestack }
remove_from_symtablestack;
{ restore labels }
aktexitlabel:=oldexitlabel;
aktexit2label:=oldexit2label;
{ restore }
aktmaxfpuregisters:=oldaktmaxfpuregisters;
aktfilepos:=oldfilepos;
current_procdef:=oldprocdef;
current_procinfo:=oldprocinfo;
end;
procedure tcgprocinfo.add_to_symtablestack;
var
_class,hp : tobjectdef;
begin
{ insert symtables for the class, but only if it is no nested function }
if assigned(procdef._class) and
not(assigned(parent) and
assigned(parent.procdef) and
assigned(parent.procdef._class)) then
begin
{ insert them in the reverse order }
hp:=nil;
repeat
_class:=procdef._class;
while _class.childof<>hp do
_class:=_class.childof;
hp:=_class;
_class.symtable.next:=symtablestack;
symtablestack:=_class.symtable;
until hp=procdef._class;
end;
{ insert parasymtable in symtablestack when parsing
a function }
if procdef.parast.symtablelevel>=normal_function_level then
begin
procdef.parast.next:=symtablestack;
symtablestack:=procdef.parast;
end;
procdef.localst.next:=symtablestack;
symtablestack:=procdef.localst;
end;
procedure tcgprocinfo.remove_from_symtablestack;
begin
{ remove localst/parast }
if procdef.parast.symtablelevel>=normal_function_level then
symtablestack:=symtablestack.next.next
else
symtablestack:=symtablestack.next;
{ remove class member symbol tables }
while symtablestack.symtabletype=objectsymtable do
symtablestack:=symtablestack.next;
end;
procedure tcgprocinfo.resetprocdef;
begin
{ the local symtables can be deleted, but the parast } { the local symtables can be deleted, but the parast }
{ doesn't, (checking definitons when calling a } { doesn't, (checking definitons when calling a }
{ function } { function }
@ -768,49 +734,133 @@ implementation
{ so no dispose here !! } { so no dispose here !! }
if assigned(code) and if assigned(code) and
not(cs_browser in aktmoduleswitches) and not(cs_browser in aktmoduleswitches) and
(current_procdef.proccalloption<>pocall_inline) then (procdef.proccalloption<>pocall_inline) then
begin begin
if current_procdef.parast.symtablelevel>=normal_function_level then if procdef.parast.symtablelevel>=normal_function_level then
current_procdef.localst.free; procdef.localst.free;
current_procdef.localst:=nil; procdef.localst:=nil;
end; end;
{ all registers can be used again }
rg.resetusableregisters;
{ only now we can remove the temps }
tg.resettempgen;
{ remove code tree, if not inline procedure } { remove code tree, if not inline procedure }
if assigned(code) then if assigned(code) then
begin begin
{ the inline procedure has already got a copy of the tree { the inline procedure has already got a copy of the tree
stored in current_procdef.code } stored in current_procdef.code }
code.free; code.free;
if (current_procdef.proccalloption<>pocall_inline) then if (procdef.proccalloption<>pocall_inline) then
current_procdef.code:=nil; procdef.code:=nil;
end; end;
end;
{ remove class member symbol tables }
while symtablestack.symtabletype=objectsymtable do
symtablestack:=symtablestack.next;
aktmaxfpuregisters:=oldaktmaxfpuregisters; procedure tcgprocinfo.parse_body;
var
oldprocdef : tprocdef;
oldprocinfo : tprocinfo;
begin
oldprocdef:=current_procdef;
oldprocinfo:=current_procinfo;
current_procinfo:=self;
current_procdef:=procdef;
{ calculate the lexical level }
if procdef.parast.symtablelevel>maxnesting then
Message(parser_e_too_much_lexlevel);
{ static is also important for local procedures !! }
if (po_staticmethod in procdef.procoptions) then
allow_only_static:=true
else if (procdef.parast.symtablelevel=normal_function_level) then
allow_only_static:=false;
{ reset break and continue labels }
block_type:=bt_general;
{$ifdef state_tracking}
{ aktstate:=Tstate_storage.create;}
{$endif state_tracking}
{ create a local symbol table for this routine }
if not assigned(procdef.localst) then
procdef.insert_localst;
{ add parast/localst to symtablestack }
add_to_symtablestack;
{ constant symbols are inserted in this symboltable }
constsymtable:=symtablestack;
{ save entry info }
entrypos:=aktfilepos;
entryswitches:=aktlocalswitches;
{ parse the code ... }
code:=block(current_module.islibrary);
{ save exit info }
exitswitches:=aktlocalswitches;
exitpos:=last_endtoken_filepos;
if assigned(code) then
begin
{ get a better entry point }
entrypos:=code.fileinfo;
{ the procedure is now defined }
procdef.forwarddef:=false;
{ add implicit entry and exit code }
add_entry_exit_code(code,entrypos,exitpos);
if (Errorcount=0) then
begin
{ check if forwards are resolved }
tstoredsymtable(procdef.localst).check_forwards;
{ check if all labels are used }
tstoredsymtable(procdef.localst).checklabels;
{ remove cross unit overloads }
tstoredsymtable(procdef.localst).unchain_overloaded;
end;
{ check for unused symbols, but only if there is no asm block }
if not(pi_uses_asm in flags) then
begin
{ not for unit init, becuase the var can be used in finalize,
it will be done in proc_unit }
if not(procdef.proctypeoption in [potype_proginit,potype_unitinit,potype_unitfinalize]) then
tstoredsymtable(procdef.localst).allsymbolsused;
tstoredsymtable(procdef.parast).allsymbolsused;
end;
{ Finish type checking pass }
do_resulttypepass(code);
{ Print the node to tree.log }
if paraprintnodetree=1 then
printnode_procdef(procdef);
end;
{ store a copy of the original tree for inline, for
normal procedures only store a reference to the
current tree }
if (procdef.proccalloption=pocall_inline) then
procdef.code:=code.getcopy
else
procdef.code:=code;
{ ... remove symbol tables }
remove_from_symtablestack;
{$ifdef state_tracking} {$ifdef state_tracking}
{ aktstate.destroy;} { aktstate.destroy;}
{$endif state_tracking} {$endif state_tracking}
{ restore filepos, the switches are already set }
aktfilepos:=savepos;
{ restore labels }
aktexitlabel:=oldexitlabel;
aktexit2label:=oldexit2label;
quickexitlabel:=oldquickexitlabel;
{ reset to normal non static function } { reset to normal non static function }
if (current_procdef.parast.symtablelevel=normal_function_level) then if (current_procdef.parast.symtablelevel=normal_function_level) then
allow_only_static:=false; allow_only_static:=false;
current_procdef:=oldprocdef; current_procdef:=oldprocdef;
current_procinfo:=oldprocinfo;
end; end;
@ -852,14 +902,32 @@ implementation
Parses the procedure directives, then parses the procedure body, then Parses the procedure directives, then parses the procedure body, then
generates the code for it generates the code for it
} }
procedure do_generate_code(pi:tcgprocinfo);
var
hpi : tcgprocinfo;
begin
{ process nested procs first }
hpi:=tcgprocinfo(pi.nestedprocs.first);
while assigned(hpi) do
begin
do_generate_code(hpi);
hpi:=tcgprocinfo(hpi.next);
end;
{ generate code for this procedure }
pi.generate_code;
pi.resetprocdef;
end;
var var
oldprocdef : tprocdef; oldprocdef : tprocdef;
old_current_procinfo : tprocinfo; old_current_procinfo : tprocinfo;
oldconstsymtable : tsymtable; oldconstsymtable : tsymtable;
oldselftokenmode, oldselftokenmode,
oldfailtokenmode : tmodeswitch; oldfailtokenmode : tmodeswitch;
pdflags : word; pdflags : tpdflags;
pd : tprocdef; pd : tprocdef;
isnestedproc : boolean;
begin begin
{ save old state } { save old state }
oldprocdef:=current_procdef; oldprocdef:=current_procdef;
@ -869,18 +937,14 @@ implementation
{ reset current_procdef to nil to be sure that nothing is writing { reset current_procdef to nil to be sure that nothing is writing
to an other procdef } to an other procdef }
current_procdef:=nil; current_procdef:=nil;
current_procinfo:=nil;
{ create a new procedure }
current_procinfo:=cprocinfo.create(old_current_procinfo);
current_module.procinfo:=current_procinfo;
{ parse procedure declaration } { parse procedure declaration }
if assigned(current_procinfo.parent) and if assigned(old_current_procinfo) and
assigned(current_procinfo.parent.procdef) then assigned(old_current_procinfo.procdef) then
pd:=parse_proc_dec(current_procinfo.parent.procdef._class) pd:=parse_proc_dec(old_current_procinfo.procdef._class)
else else
pd:=parse_proc_dec(nil); pd:=parse_proc_dec(nil);
current_procinfo.procdef:=pd;
{ set the default function options } { set the default function options }
if parse_only then if parse_only then
@ -889,15 +953,17 @@ implementation
{ set also the interface flag, for better error message when the { set also the interface flag, for better error message when the
implementation doesn't much this header } implementation doesn't much this header }
pd.interfacedef:=true; pd.interfacedef:=true;
pdflags:=pd_interface; include(pd.procoptions,po_public);
pdflags:=[pd_interface];
end end
else else
begin begin
pdflags:=pd_body; pdflags:=[pd_body];
if (not current_module.in_interface) then if (not current_module.in_interface) then
pdflags:=pdflags or pd_implemen; include(pdflags,pd_implemen);
if (not current_module.is_unit) or (cs_create_smart in aktmoduleswitches) then if (not current_module.is_unit) or
pdflags:=pdflags or pd_global; (cs_create_smart in aktmoduleswitches) then
include(pd.procoptions,po_public);
pd.forwarddef:=false; pd.forwarddef:=false;
end; end;
@ -918,7 +984,7 @@ implementation
begin begin
{ A method must be forward defined (in the object declaration) } { A method must be forward defined (in the object declaration) }
if assigned(pd._class) and if assigned(pd._class) and
(not assigned(current_procinfo.parent.procdef._class)) then (not assigned(old_current_procinfo.procdef._class)) then
begin begin
Message1(parser_e_header_dont_match_any_member,pd.fullprocname(false)); Message1(parser_e_header_dont_match_any_member,pd.fullprocname(false));
tprocsym(pd.procsym).write_parameter_lists(pd); tprocsym(pd.procsym).write_parameter_lists(pd);
@ -941,79 +1007,81 @@ implementation
begin begin
{ check the global flag, for delphi this is not { check the global flag, for delphi this is not
required } required }
if not(m_delphi in aktmodeswitches) and {if not(m_delphi in aktmodeswitches) and
(pi_is_global in current_procinfo.flags) then not(pd.procsym.owner.symtabletype=globalsymtable) then
Message(parser_e_overloaded_must_be_all_global); Message(parser_e_overloaded_must_be_all_global);}
end; end;
end; end;
end; end;
{ update procinfo, because the procdef can be
changed by check_identical_proc (PFV) }
current_procinfo.procdef:=pd;
{ compile procedure when a body is needed } { compile procedure when a body is needed }
if (pdflags and pd_body)<>0 then if (pd_body in pdflags) then
begin begin
Message1(parser_d_procedure_start,pd.fullprocname(false)); Message1(parser_d_procedure_start,pd.fullprocname(false));
pd.aliasnames.insert(pd.mangledname);
{ Insert result variables in the localst } { create a new procedure }
insert_funcret_local(pd); current_procinfo:=cprocinfo.create(old_current_procinfo);
current_module.procinfo:=current_procinfo;
current_procinfo.procdef:=pd;
isnestedproc:=(current_procinfo.procdef.parast.symtablelevel>normal_function_level);
{ Insert local copies for value para } { Insert mangledname }
pd.parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}insert_local_value_para,nil); pd.aliasnames.insert(pd.mangledname);
{ Insert result variables in the localst }
insert_funcret_local(pd);
{ Insert local copies for value para }
pd.parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}insert_local_value_para,nil);
{ Update parameter information }
current_procinfo.allocate_implicit_parameter;
{$ifdef i386} {$ifdef i386}
{ add implicit pushes for interrupt routines } { add implicit pushes for interrupt routines }
if (po_interrupt in pd.procoptions) then if (po_interrupt in pd.procoptions) then
current_procinfo.allocate_interrupt_stackframe; current_procinfo.allocate_interrupt_stackframe;
{$endif i386} {$endif i386}
{$ifdef powerpc} { Calculate offsets }
{ temp hack for nested procedures on ppc } current_procinfo.after_header;
{ Calculate offsets } { set _FAIL as keyword if constructor }
current_procinfo.after_header; if (pd.proctypeoption=potype_constructor) then
begin
oldfailtokenmode:=tokeninfo^[_FAIL].keyword;
tokeninfo^[_FAIL].keyword:=m_all;
end;
{ set _SELF as keyword if methods }
if assigned(pd._class) then
begin
oldselftokenmode:=tokeninfo^[_SELF].keyword;
tokeninfo^[_SELF].keyword:=m_all;
end;
{ Update parameter information } tcgprocinfo(current_procinfo).parse_body;
current_procinfo.allocate_implicit_parameter;
{$else powerpc}
{ Update parameter information }
current_procinfo.allocate_implicit_parameter;
{ Calculate offsets } { When it's a nested procedure then defer the code generation,
current_procinfo.after_header; when back at normal function level then generate the code
{$endif powerpc} for all defered nested procedures and the current procedure }
if isnestedproc then
tcgprocinfo(current_procinfo.parent).nestedprocs.insert(current_procinfo)
else
do_generate_code(tcgprocinfo(current_procinfo));
{ set _FAIL as keyword if constructor } { reset _FAIL as _SELF normal }
if (pd.proctypeoption=potype_constructor) then if (pd.proctypeoption=potype_constructor) then
begin tokeninfo^[_FAIL].keyword:=oldfailtokenmode;
oldfailtokenmode:=tokeninfo^[_FAIL].keyword; if assigned(pd._class) then
tokeninfo^[_FAIL].keyword:=m_all; tokeninfo^[_SELF].keyword:=oldselftokenmode;
end; consume(_SEMICOLON);
{ set _SELF as keyword if methods }
if assigned(pd._class) then
begin
oldselftokenmode:=tokeninfo^[_SELF].keyword;
tokeninfo^[_SELF].keyword:=m_all;
end;
compile_proc_body(pd,((pdflags and pd_global)<>0),assigned(current_procinfo.parent.procdef._class)); { release procinfo }
if tprocinfo(current_module.procinfo)<>current_procinfo then
{ reset _FAIL as _SELF normal } internalerror(200304274);
if (pd.proctypeoption=potype_constructor) then current_module.procinfo:=current_procinfo.parent;
tokeninfo^[_FAIL].keyword:=oldfailtokenmode; if not isnestedproc then
if assigned(pd._class) then current_procinfo.free;
tokeninfo^[_SELF].keyword:=oldselftokenmode; end;
consume(_SEMICOLON);
end;
{ release procinfo }
if tprocinfo(current_module.procinfo)<>current_procinfo then
internalerror(200304274);
current_module.procinfo:=current_procinfo.parent;
current_procinfo.free;
{ Restore old state } { Restore old state }
constsymtable:=oldconstsymtable; constsymtable:=oldconstsymtable;
@ -1138,10 +1206,16 @@ implementation
symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class,nil); symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class,nil);
end; end;
begin
cprocinfo:=tcgprocinfo;
end. end.
{ {
$Log$ $Log$
Revision 1.114 2003-05-16 20:00:39 jonas Revision 1.115 2003-05-22 21:31:35 peter
* defer codegeneration for nested procedures
Revision 1.114 2003/05/16 20:00:39 jonas
* powerpc nested procedure fixes, should work completely now if all * powerpc nested procedure fixes, should work completely now if all
local variables of the parent procedure are declared before the local variables of the parent procedure are declared before the
nested procedures are declared nested procedures are declared

8
compiler/symconst.pas
View File

@ -194,7 +194,8 @@ type
po_leftright, { push arguments from left to right } po_leftright, { push arguments from left to right }
po_clearstack, { caller clears the stack } po_clearstack, { caller clears the stack }
po_internconst, { procedure has constant evaluator intern } po_internconst, { procedure has constant evaluator intern }
po_addressonly { flag that only the address of a method is returned and not a full methodpointer } po_addressonly, { flag that only the address of a method is returned and not a full methodpointer }
po_public { procedure is exported }
); );
tprocoptions=set of tprocoption; tprocoptions=set of tprocoption;
@ -351,7 +352,10 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.55 2003-05-15 21:10:32 peter Revision 1.56 2003-05-22 21:31:35 peter
* defer codegeneration for nested procedures
Revision 1.55 2003/05/15 21:10:32 peter
* remove po_containsself * remove po_containsself
Revision 1.54 2003/05/09 17:47:03 peter Revision 1.54 2003/05/09 17:47:03 peter