paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-17 08:59:05 +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

29
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);
@ -850,11 +851,8 @@ implementation
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);
stringdispose(current_module.realmodulename);
current_module.modulename:=stringdup(pattern);
current_module.realmodulename:=stringdup(orgpattern);
{ check for system unit } { check for system unit }
new(s2); new(s2);
s2^:=upper(SplitName(main_file.name^)); s2^:=upper(SplitName(main_file.name^));
@ -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

520
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,163 +528,81 @@ implementation
end; end;
procedure compile_proc_body(pd:tprocdef;make_global,parent_has_class:boolean); {****************************************************************************
{ TCGProcInfo
Compile the body of a procedure ****************************************************************************}
}
constructor tcgprocinfo.create(aparent:tprocinfo);
begin
inherited Create(aparent);
nestedprocs:=tlinkedlist.create;
end;
destructor tcgprocinfo.destroy;
begin
inherited destroy;
nestedprocs.free;
end;
procedure tcgprocinfo.generate_code;
var var
oldexitlabel,oldexit2label : tasmlabel; oldprocdef : tprocdef;
oldquickexitlabel:tasmlabel; oldprocinfo : tprocinfo;
_class,hp:tobjectdef; oldexitlabel,
{ switches can change inside the procedure } oldexit2label : tasmlabel;
entryswitches, exitswitches : tlocalswitches; oldaktmaxfpuregisters : longint;
oldaktmaxfpuregisters,localmaxfpuregisters : longint; oldfilepos : tfileposinfo;
{ code for the subroutine as tree }
code:tnode;
{ true when no stackframe is required } { true when no stackframe is required }
nostackframe:boolean; nostackframe:boolean;
{ number of bytes which have to be cleared by RET } { number of bytes which have to be cleared by RET }
parasize:longint; parasize:longint;
{ filepositions }
entrypos,
savepos,
exitpos : tfileposinfo;
oldprocdef : tprocdef;
begin begin
{ 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;
oldprocinfo:=current_procinfo;
oldprocdef:=current_procdef; oldprocdef:=current_procdef;
current_procdef:=pd; oldfilepos:=aktfilepos;
oldaktmaxfpuregisters:=aktmaxfpuregisters;
{ calculate the lexical level } current_procinfo:=self;
if current_procdef.parast.symtablelevel>maxnesting then current_procdef:=procdef;
Message(parser_e_too_much_lexlevel);
{ static is also important for local procedures !! }
if (po_staticmethod in current_procdef.procoptions) then
allow_only_static:=true
else if (current_procdef.parast.symtablelevel=normal_function_level) then
allow_only_static:=false;
{ save old labels } { save old labels }
oldexitlabel:=aktexitlabel; oldexitlabel:=aktexitlabel;
oldexit2label:=aktexit2label; oldexit2label:=aktexit2label;
oldquickexitlabel:=quickexitlabel;
{ get new labels } { get new labels }
objectlibrary.getlabel(aktexitlabel); objectlibrary.getlabel(aktexitlabel);
objectlibrary.getlabel(aktexit2label); 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; aktbreaklabel:=nil;
aktcontinuelabel:=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 } { add parast/localst to symtablestack }
if assigned(current_procdef._class) and not(parent_has_class) then add_to_symtablestack;
begin
{ insert them in the reverse order }
hp:=nil;
repeat
_class:=current_procdef._class;
while _class.childof<>hp do
_class:=_class.childof;
hp:=_class;
_class.symtable.next:=symtablestack;
symtablestack:=_class.symtable;
until hp=current_procdef._class;
end;
{ insert parasymtable in symtablestack when parsing
a function }
if current_procdef.parast.symtablelevel>=normal_function_level then
begin
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 } { reset the temporary memory }
rg.cleartempgen; rg.cleartempgen;
rg.usedinproc:=[]; rg.usedinproc:=[];
rg.usedbyproc:=[]; rg.usedbyproc:=[];
{ save entry info }
entrypos:=aktfilepos;
entryswitches:=aktlocalswitches;
localmaxfpuregisters:=aktmaxfpuregisters;
{ parse the code ... }
code:=block(current_module.islibrary);
{ get a better entry point }
if assigned(code) then
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
point to the unit initialization. If the unit has no initialization,
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 } { set the start offset to the start of the temp area in the stack }
tg.setfirsttemp(current_procinfo.firsttemp_offset); tg.setfirsttemp(current_procinfo.firsttemp_offset);
{ ... and generate assembler }
{ but set the right switches for entry !! }
aktlocalswitches:=entryswitches;
oldaktmaxfpuregisters:=aktmaxfpuregisters;
aktmaxfpuregisters:=localmaxfpuregisters;
if assigned(code) then
begin
{ the procedure is now defined }
current_procdef.forwarddef:=false;
if paraprintnodetree=1 then
printnode_procdef(current_procdef);
{ only generate the code if no type errors are found, else
finish at least the type checking pass }
{$ifndef NOPASS2}
if (status.errorcount=0) then
begin
generatecode(code); 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) } { first generate entry code with the correct position and switches }
if (pi_needs_implicit_finally in current_procinfo.flags) or aktfilepos:=current_procinfo.entrypos;
(pi_uses_exceptions in current_procinfo.flags) then aktlocalswitches:=current_procinfo.entryswitches;
begin genentrycode(current_procinfo.aktentrycode,0,parasize,nostackframe,false);
rg.usedinproc := ALL_REGISTERS;
end;
{ now generate exit code with the correct position and switches } { now generate exit code with the correct position and switches }
aktfilepos:=exitpos; aktfilepos:=current_procinfo.exitpos;
aktlocalswitches:=exitswitches; aktlocalswitches:=current_procinfo.exitswitches;
genexitcode(current_procinfo.aktexitcode,parasize,nostackframe,false); genexitcode(current_procinfo.aktexitcode,parasize,nostackframe,false);
{ now all the registers used are known } { now all the registers used are known }
@ -709,6 +640,7 @@ implementation
{$endif NoOpt} {$endif NoOpt}
{$endif newra} {$endif newra}
end; end;
{ save local data (casetable) also in the same file } { save local data (casetable) also in the same file }
if assigned(current_procinfo.aktlocaldata) and if assigned(current_procinfo.aktlocaldata) and
(not current_procinfo.aktlocaldata.empty) then (not current_procinfo.aktlocaldata.empty) then
@ -722,44 +654,78 @@ implementation
if (cs_create_smart in aktmoduleswitches) then if (cs_create_smart in aktmoduleswitches) then
codeSegment.concat(Tai_cut.Create); codeSegment.concat(Tai_cut.Create);
codeSegment.concatlist(current_procinfo.aktproccode); codeSegment.concatlist(current_procinfo.aktproccode);
end
else { all registers can be used again }
do_resulttypepass(code); rg.resetusableregisters;
{$else NOPASS2} { only now we can remove the temps }
do_resulttypepass(code); tg.resettempgen;
{$endif NOPASS2}
{ restore symtablestack }
remove_from_symtablestack;
{ restore labels }
aktexitlabel:=oldexitlabel;
aktexit2label:=oldexit2label;
{ restore }
aktmaxfpuregisters:=oldaktmaxfpuregisters;
aktfilepos:=oldfilepos;
current_procdef:=oldprocdef;
current_procinfo:=oldprocinfo;
end; end;
{ ... remove symbol tables }
if current_procdef.parast.symtablelevel>=normal_function_level then 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 symtablestack:=symtablestack.next.next
else else
symtablestack:=symtablestack.next; symtablestack:=symtablestack.next;
{ ... check for unused symbols } { remove class member symbol tables }
{ but only if there is no asm block } while symtablestack.symtabletype=objectsymtable do
if assigned(code) then symtablestack:=symtablestack.next;
begin
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; 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,21 +1007,25 @@ 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));
{ create a new procedure }
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 mangledname }
pd.aliasnames.insert(pd.mangledname); pd.aliasnames.insert(pd.mangledname);
{ Insert result variables in the localst } { Insert result variables in the localst }
@ -964,28 +1034,17 @@ implementation
{ Insert local copies for value para } { Insert local copies for value para }
pd.parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}insert_local_value_para,nil); 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}
{ temp hack for nested procedures on ppc }
{ Calculate offsets } { Calculate offsets }
current_procinfo.after_header; current_procinfo.after_header;
{ Update parameter information }
current_procinfo.allocate_implicit_parameter;
{$else powerpc}
{ Update parameter information }
current_procinfo.allocate_implicit_parameter;
{ Calculate offsets }
current_procinfo.after_header;
{$endif powerpc}
{ set _FAIL as keyword if constructor } { set _FAIL as keyword if constructor }
if (pd.proctypeoption=potype_constructor) then if (pd.proctypeoption=potype_constructor) then
begin begin
@ -999,7 +1058,15 @@ implementation
tokeninfo^[_SELF].keyword:=m_all; tokeninfo^[_SELF].keyword:=m_all;
end; end;
compile_proc_body(pd,((pdflags and pd_global)<>0),assigned(current_procinfo.parent.procdef._class)); tcgprocinfo(current_procinfo).parse_body;
{ When it's a nested procedure then defer the code generation,
when back at normal function level then generate the code
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));
{ reset _FAIL as _SELF normal } { reset _FAIL as _SELF normal }
if (pd.proctypeoption=potype_constructor) then if (pd.proctypeoption=potype_constructor) then
@ -1007,13 +1074,14 @@ implementation
if assigned(pd._class) then if assigned(pd._class) then
tokeninfo^[_SELF].keyword:=oldselftokenmode; tokeninfo^[_SELF].keyword:=oldselftokenmode;
consume(_SEMICOLON); consume(_SEMICOLON);
end;
{ release procinfo } { release procinfo }
if tprocinfo(current_module.procinfo)<>current_procinfo then if tprocinfo(current_module.procinfo)<>current_procinfo then
internalerror(200304274); internalerror(200304274);
current_module.procinfo:=current_procinfo.parent; current_module.procinfo:=current_procinfo.parent;
if not isnestedproc then
current_procinfo.free; current_procinfo.free;
end;
{ 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