mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-26 15:13:58 +02:00
66f8276445
* support for case aware filesystems (Windows), they do now only
one lookup if a file exists
* add -WI option to generate import section for DLL imports or
let the linker handle it. Default is still import section until
the Makefiles are fixed, then the generation can be left to the
linker
git-svn-id: trunk@2274 -
1707 lines
63 KiB
ObjectPascal
1707 lines
63 KiB
ObjectPascal
{
|
|
Copyright (c) 1998-2002 by Florian Klaempfl, Daniel Mantione
|
|
|
|
Does the parsing and codegeneration at subroutine level
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program; if not, write to the Free Software
|
|
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
|
****************************************************************************
|
|
}
|
|
unit psub;
|
|
|
|
{$i fpcdefs.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
cclasses,globals,
|
|
node,nbas,
|
|
symdef,procinfo;
|
|
|
|
type
|
|
tcgprocinfo = class(tprocinfo)
|
|
private
|
|
procedure add_entry_exit_code;
|
|
public
|
|
{ code for the subroutine as tree }
|
|
code : tnode;
|
|
{ positions in the tree for init/final }
|
|
entry_asmnode,
|
|
loadpara_asmnode,
|
|
exitlabel_asmnode,
|
|
stackcheck_asmnode,
|
|
init_asmnode,
|
|
final_asmnode : tasmnode;
|
|
{ list to store the procinfo's of the nested procedures }
|
|
nestedprocs : tlinkedlist;
|
|
constructor create(aparent:tprocinfo);override;
|
|
destructor destroy;override;
|
|
procedure printproc;
|
|
procedure generate_code;
|
|
procedure resetprocdef;
|
|
procedure add_to_symtablestack;
|
|
procedure remove_from_symtablestack;
|
|
procedure parse_body;
|
|
|
|
function stack_tainting_parameter : boolean;
|
|
function has_assembler_child : boolean;
|
|
end;
|
|
|
|
|
|
procedure printnode_reset;
|
|
|
|
{ reads the declaration blocks }
|
|
procedure read_declarations(islibrary : boolean);
|
|
|
|
{ reads declarations in the interface part of a unit }
|
|
procedure read_interface_declarations;
|
|
|
|
procedure generate_specialization_procs;
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
{ common }
|
|
cutils,
|
|
{ global }
|
|
globtype,tokens,verbose,comphook,
|
|
systems,
|
|
{ aasm }
|
|
cpubase,aasmbase,aasmtai,
|
|
{ symtable }
|
|
symconst,symbase,symsym,symtype,symtable,defutil,
|
|
paramgr,
|
|
ppu,fmodule,
|
|
{ pass 1 }
|
|
nutils,nld,ncal,ncon,nflw,nadd,ncnv,nmem,
|
|
pass_1,
|
|
{$ifdef state_tracking}
|
|
nstate,
|
|
{$endif state_tracking}
|
|
{ pass 2 }
|
|
{$ifndef NOPASS2}
|
|
pass_2,
|
|
{$endif}
|
|
{ parser }
|
|
scanner,import,gendef,
|
|
pbase,pstatmnt,pdecl,pdecsub,pexports,
|
|
{ codegen }
|
|
tgobj,cgbase,cgobj,dbgbase,
|
|
ncgutil,regvars
|
|
{$if defined(arm) or defined(powerpc) or defined(powerpc64)}
|
|
,aasmcpu
|
|
{$endif arm}
|
|
{$ifndef NOOPT}
|
|
{$ifdef i386}
|
|
,aopt386
|
|
{$else i386}
|
|
,aopt
|
|
{$endif i386}
|
|
{$endif}
|
|
;
|
|
|
|
{****************************************************************************
|
|
PROCEDURE/FUNCTION BODY PARSING
|
|
****************************************************************************}
|
|
|
|
procedure initializevars(p:tnamedindexitem;arg:pointer);
|
|
var
|
|
b : tblocknode;
|
|
begin
|
|
if not (tsym(p).typ in [localvarsym,globalvarsym]) then
|
|
exit;
|
|
with tabstractnormalvarsym(p) do
|
|
begin
|
|
if assigned(defaultconstsym) then
|
|
begin
|
|
b:=tblocknode(arg);
|
|
b.left:=cstatementnode.create(
|
|
cassignmentnode.create(
|
|
cloadnode.create(tsym(p),tsym(p).owner),
|
|
cloadnode.create(defaultconstsym,defaultconstsym.owner)),
|
|
b.left);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure check_finalize_paras(p : tnamedindexitem;arg:pointer);
|
|
begin
|
|
if (tsym(p).typ=paravarsym) and
|
|
(tparavarsym(p).varspez=vs_value) and
|
|
not is_class(tparavarsym(p).vartype.def) and
|
|
tparavarsym(p).vartype.def.needs_inittable then
|
|
include(current_procinfo.flags,pi_needs_implicit_finally);
|
|
end;
|
|
|
|
|
|
procedure check_finalize_locals(p : tnamedindexitem;arg:pointer);
|
|
begin
|
|
if (tsym(p).typ=localvarsym) and
|
|
(tlocalvarsym(p).refs>0) and
|
|
not(vo_is_funcret in tlocalvarsym(p).varoptions) and
|
|
not(is_class(tlocalvarsym(p).vartype.def)) and
|
|
tlocalvarsym(p).vartype.def.needs_inittable then
|
|
include(current_procinfo.flags,pi_needs_implicit_finally);
|
|
end;
|
|
|
|
|
|
function block(islibrary : boolean) : tnode;
|
|
begin
|
|
{ parse const,types and vars }
|
|
read_declarations(islibrary);
|
|
|
|
{ do we have an assembler block without the po_assembler?
|
|
we should allow this for Delphi compatibility (PFV) }
|
|
if (token=_ASM) and (m_delphi in aktmodeswitches) then
|
|
include(current_procinfo.procdef.procoptions,po_assembler);
|
|
|
|
{ Handle assembler block different }
|
|
if (po_assembler in current_procinfo.procdef.procoptions) then
|
|
begin
|
|
block:=assembler_block;
|
|
exit;
|
|
end;
|
|
|
|
{Unit initialization?.}
|
|
if (
|
|
assigned(current_procinfo.procdef.localst) and
|
|
(current_procinfo.procdef.localst.symtablelevel=main_program_level) and
|
|
(current_module.is_unit)
|
|
) or
|
|
islibrary then
|
|
begin
|
|
if (token=_END) then
|
|
begin
|
|
consume(_END);
|
|
{ We need at least a node, else the entry/exit code is not
|
|
generated and thus no PASCALMAIN symbol which we need (PFV) }
|
|
if islibrary then
|
|
block:=cnothingnode.create
|
|
else
|
|
block:=nil;
|
|
end
|
|
else
|
|
begin
|
|
if token=_INITIALIZATION then
|
|
begin
|
|
{ The library init code is already called and does not
|
|
need to be in the initfinal table (PFV) }
|
|
if not islibrary then
|
|
current_module.flags:=current_module.flags or uf_init;
|
|
block:=statement_block(_INITIALIZATION);
|
|
end
|
|
else if (token=_FINALIZATION) then
|
|
begin
|
|
if (current_module.flags and uf_finalize)<>0 then
|
|
block:=statement_block(_FINALIZATION)
|
|
else
|
|
begin
|
|
{ can we allow no INITIALIZATION for DLL ??
|
|
I think it should work PM }
|
|
block:=nil;
|
|
exit;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
{ The library init code is already called and does not
|
|
need to be in the initfinal table (PFV) }
|
|
if not islibrary then
|
|
current_module.flags:=current_module.flags or uf_init;
|
|
block:=statement_block(_BEGIN);
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
block:=statement_block(_BEGIN);
|
|
if symtablestack.symtabletype=localsymtable then
|
|
symtablestack.foreach_static(@initializevars,block);
|
|
end;
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
PROCEDURE/FUNCTION COMPILING
|
|
****************************************************************************}
|
|
|
|
procedure printnode_reset;
|
|
begin
|
|
assign(printnodefile,treelogfilename);
|
|
{$I-}
|
|
rewrite(printnodefile);
|
|
{$I+}
|
|
if ioresult<>0 then
|
|
begin
|
|
Comment(V_Error,'Error creating '+treelogfilename);
|
|
exit;
|
|
end;
|
|
close(printnodefile);
|
|
end;
|
|
|
|
|
|
function generate_bodyentry_block:tnode;
|
|
var
|
|
srsym : tsym;
|
|
para : tcallparanode;
|
|
newstatement : tstatementnode;
|
|
htype : ttype;
|
|
begin
|
|
result:=internalstatements(newstatement);
|
|
|
|
if assigned(current_procinfo.procdef._class) then
|
|
begin
|
|
{ a constructor needs a help procedure }
|
|
if (current_procinfo.procdef.proctypeoption=potype_constructor) then
|
|
begin
|
|
if is_class(current_procinfo.procdef._class) then
|
|
begin
|
|
include(current_procinfo.flags,pi_needs_implicit_finally);
|
|
srsym:=search_class_member(current_procinfo.procdef._class,'NEWINSTANCE');
|
|
if assigned(srsym) and
|
|
(srsym.typ=procsym) then
|
|
begin
|
|
{ if vmt>1 then newinstance }
|
|
addstatement(newstatement,cifnode.create(
|
|
caddnode.create(gtn,
|
|
ctypeconvnode.create_internal(
|
|
load_vmt_pointer_node,
|
|
voidpointertype),
|
|
cpointerconstnode.create(1,voidpointertype)),
|
|
cassignmentnode.create(
|
|
ctypeconvnode.create_internal(
|
|
load_self_pointer_node,
|
|
voidpointertype),
|
|
ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_vmt_pointer_node,[])),
|
|
nil));
|
|
end
|
|
else
|
|
internalerror(200305108);
|
|
end
|
|
else
|
|
if is_object(current_procinfo.procdef._class) then
|
|
begin
|
|
htype.setdef(current_procinfo.procdef._class);
|
|
htype.setdef(tpointerdef.create(htype));
|
|
{ parameter 3 : vmt_offset }
|
|
{ parameter 2 : address of pointer to vmt,
|
|
this is required to allow setting the vmt to -1 to indicate
|
|
that memory was allocated }
|
|
{ parameter 1 : self pointer }
|
|
para:=ccallparanode.create(
|
|
cordconstnode.create(current_procinfo.procdef._class.vmt_offset,s32inttype,false),
|
|
ccallparanode.create(
|
|
ctypeconvnode.create_internal(
|
|
load_vmt_pointer_node,
|
|
voidpointertype),
|
|
ccallparanode.create(
|
|
ctypeconvnode.create_internal(
|
|
load_self_pointer_node,
|
|
voidpointertype),
|
|
nil)));
|
|
addstatement(newstatement,cassignmentnode.create(
|
|
ctypeconvnode.create_internal(
|
|
load_self_pointer_node,
|
|
voidpointertype),
|
|
ccallnode.createintern('fpc_help_constructor',para)));
|
|
end
|
|
else
|
|
internalerror(200305103);
|
|
{ if self=nil then exit
|
|
calling fail instead of exit is useless because
|
|
there is nothing to dispose (PFV) }
|
|
addstatement(newstatement,cifnode.create(
|
|
caddnode.create(equaln,
|
|
load_self_pointer_node,
|
|
cnilnode.create),
|
|
cexitnode.create(nil),
|
|
nil));
|
|
end;
|
|
|
|
{ maybe call BeforeDestruction for classes }
|
|
if (current_procinfo.procdef.proctypeoption=potype_destructor) and
|
|
is_class(current_procinfo.procdef._class) then
|
|
begin
|
|
srsym:=search_class_member(current_procinfo.procdef._class,'BEFOREDESTRUCTION');
|
|
if assigned(srsym) and
|
|
(srsym.typ=procsym) then
|
|
begin
|
|
{ if vmt<>0 then beforedestruction }
|
|
addstatement(newstatement,cifnode.create(
|
|
caddnode.create(unequaln,
|
|
load_vmt_pointer_node,
|
|
cnilnode.create),
|
|
ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
|
|
nil));
|
|
end
|
|
else
|
|
internalerror(200305104);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
function generate_bodyexit_block:tnode;
|
|
var
|
|
srsym : tsym;
|
|
para : tcallparanode;
|
|
newstatement : tstatementnode;
|
|
begin
|
|
result:=internalstatements(newstatement);
|
|
|
|
if assigned(current_procinfo.procdef._class) then
|
|
begin
|
|
{ maybe call AfterConstruction for classes }
|
|
if (current_procinfo.procdef.proctypeoption=potype_constructor) and
|
|
is_class(current_procinfo.procdef._class) then
|
|
begin
|
|
srsym:=search_class_member(current_procinfo.procdef._class,'AFTERCONSTRUCTION');
|
|
if assigned(srsym) and
|
|
(srsym.typ=procsym) then
|
|
begin
|
|
{ Self can be nil when fail is called }
|
|
{ if self<>nil and vmt<>nil then afterconstruction }
|
|
addstatement(newstatement,cifnode.create(
|
|
caddnode.create(andn,
|
|
caddnode.create(unequaln,
|
|
load_self_pointer_node,
|
|
cnilnode.create),
|
|
caddnode.create(unequaln,
|
|
load_vmt_pointer_node,
|
|
cnilnode.create)),
|
|
ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
|
|
nil));
|
|
end
|
|
else
|
|
internalerror(200305106);
|
|
end;
|
|
|
|
{ a destructor needs a help procedure }
|
|
if (current_procinfo.procdef.proctypeoption=potype_destructor) then
|
|
begin
|
|
if is_class(current_procinfo.procdef._class) then
|
|
begin
|
|
srsym:=search_class_member(current_procinfo.procdef._class,'FREEINSTANCE');
|
|
if assigned(srsym) and
|
|
(srsym.typ=procsym) then
|
|
begin
|
|
{ if self<>0 and vmt=1 then freeinstance }
|
|
addstatement(newstatement,cifnode.create(
|
|
caddnode.create(andn,
|
|
caddnode.create(unequaln,
|
|
load_self_pointer_node,
|
|
cnilnode.create),
|
|
caddnode.create(equaln,
|
|
ctypeconvnode.create(
|
|
load_vmt_pointer_node,
|
|
voidpointertype),
|
|
cpointerconstnode.create(1,voidpointertype))),
|
|
ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
|
|
nil));
|
|
end
|
|
else
|
|
internalerror(200305108);
|
|
end
|
|
else
|
|
if is_object(current_procinfo.procdef._class) then
|
|
begin
|
|
{ finalize object data }
|
|
if current_procinfo.procdef._class.needs_inittable then
|
|
addstatement(newstatement,finalize_data_node(load_self_node));
|
|
{ parameter 3 : vmt_offset }
|
|
{ parameter 2 : pointer to vmt }
|
|
{ parameter 1 : self pointer }
|
|
para:=ccallparanode.create(
|
|
cordconstnode.create(current_procinfo.procdef._class.vmt_offset,s32inttype,false),
|
|
ccallparanode.create(
|
|
ctypeconvnode.create_internal(
|
|
load_vmt_pointer_node,
|
|
voidpointertype),
|
|
ccallparanode.create(
|
|
ctypeconvnode.create_internal(
|
|
load_self_pointer_node,
|
|
voidpointertype),
|
|
nil)));
|
|
addstatement(newstatement,
|
|
ccallnode.createintern('fpc_help_destructor',para));
|
|
end
|
|
else
|
|
internalerror(200305105);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
function generate_except_block:tnode;
|
|
var
|
|
pd : tprocdef;
|
|
newstatement : tstatementnode;
|
|
begin
|
|
generate_except_block:=internalstatements(newstatement);
|
|
|
|
{ a constructor needs call destructor (if available) when it
|
|
is not inherited }
|
|
if assigned(current_procinfo.procdef._class) and
|
|
(current_procinfo.procdef.proctypeoption=potype_constructor) then
|
|
begin
|
|
pd:=current_procinfo.procdef._class.searchdestructor;
|
|
if assigned(pd) then
|
|
begin
|
|
{ if vmt<>0 then call destructor }
|
|
addstatement(newstatement,cifnode.create(
|
|
caddnode.create(unequaln,
|
|
load_vmt_pointer_node,
|
|
cnilnode.create),
|
|
ccallnode.create(nil,tprocsym(pd.procsym),pd.procsym.owner,load_self_node,[]),
|
|
nil));
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
{ no constructor }
|
|
{ must be the return value finalized before reraising the exception? }
|
|
if (not is_void(current_procinfo.procdef.rettype.def)) and
|
|
(current_procinfo.procdef.rettype.def.needs_inittable) and
|
|
(not is_class(current_procinfo.procdef.rettype.def)) then
|
|
addstatement(newstatement,finalize_data_node(load_result_node));
|
|
end;
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
TCGProcInfo
|
|
****************************************************************************}
|
|
|
|
constructor tcgprocinfo.create(aparent:tprocinfo);
|
|
begin
|
|
inherited Create(aparent);
|
|
nestedprocs:=tlinkedlist.create;
|
|
end;
|
|
|
|
|
|
destructor tcgprocinfo.destroy;
|
|
begin
|
|
nestedprocs.free;
|
|
if assigned(code) then
|
|
code.free;
|
|
inherited destroy;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.printproc;
|
|
begin
|
|
assign(printnodefile,treelogfilename);
|
|
{$I-}
|
|
append(printnodefile);
|
|
if ioresult<>0 then
|
|
rewrite(printnodefile);
|
|
{$I+}
|
|
if ioresult<>0 then
|
|
begin
|
|
Comment(V_Error,'Error creating '+treelogfilename);
|
|
exit;
|
|
end;
|
|
writeln(printnodefile);
|
|
writeln(printnodefile,'*******************************************************************************');
|
|
writeln(printnodefile,procdef.fullprocname(false));
|
|
writeln(printnodefile,'*******************************************************************************');
|
|
printnode(printnodefile,code);
|
|
close(printnodefile);
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.add_entry_exit_code;
|
|
var
|
|
finalcode,
|
|
bodyentrycode,
|
|
bodyexitcode,
|
|
exceptcode : tnode;
|
|
newblock : tblocknode;
|
|
codestatement,
|
|
newstatement : tstatementnode;
|
|
oldfilepos : tfileposinfo;
|
|
begin
|
|
oldfilepos:=aktfilepos;
|
|
{ Generate code/locations used at start of proc }
|
|
aktfilepos:=entrypos;
|
|
entry_asmnode:=casmnode.create_get_position;
|
|
loadpara_asmnode:=casmnode.create_get_position;
|
|
stackcheck_asmnode:=casmnode.create_get_position;
|
|
init_asmnode:=casmnode.create_get_position;
|
|
bodyentrycode:=generate_bodyentry_block;
|
|
{ Generate code/locations used at end of proc }
|
|
aktfilepos:=exitpos;
|
|
exitlabel_asmnode:=casmnode.create_get_position;
|
|
final_asmnode:=casmnode.create_get_position;
|
|
bodyexitcode:=generate_bodyexit_block;
|
|
|
|
{ Generate procedure by combining init+body+final,
|
|
depending on the implicit finally we need to add
|
|
an try...finally...end wrapper }
|
|
newblock:=internalstatements(newstatement);
|
|
if (cs_implicit_exceptions in aktmoduleswitches) and
|
|
(pi_needs_implicit_finally in flags) and
|
|
{ but it's useless in init/final code of units }
|
|
not(procdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) then
|
|
begin
|
|
{ Generate special exception block only needed when
|
|
implicit finaly is used }
|
|
aktfilepos:=exitpos;
|
|
exceptcode:=generate_except_block;
|
|
{ Generate code that will be in the try...finally }
|
|
finalcode:=internalstatements(codestatement);
|
|
addstatement(codestatement,bodyexitcode);
|
|
addstatement(codestatement,final_asmnode);
|
|
{ Initialize before try...finally...end frame }
|
|
addstatement(newstatement,loadpara_asmnode);
|
|
addstatement(newstatement,stackcheck_asmnode);
|
|
addstatement(newstatement,entry_asmnode);
|
|
addstatement(newstatement,init_asmnode);
|
|
addstatement(newstatement,bodyentrycode);
|
|
aktfilepos:=entrypos;
|
|
addstatement(newstatement,ctryfinallynode.create_implicit(
|
|
code,
|
|
finalcode,
|
|
exceptcode));
|
|
addstatement(newstatement,exitlabel_asmnode);
|
|
{ set flag the implicit finally has been generated }
|
|
include(flags,pi_has_implicit_finally);
|
|
end
|
|
else
|
|
begin
|
|
addstatement(newstatement,loadpara_asmnode);
|
|
addstatement(newstatement,stackcheck_asmnode);
|
|
addstatement(newstatement,entry_asmnode);
|
|
addstatement(newstatement,init_asmnode);
|
|
addstatement(newstatement,bodyentrycode);
|
|
addstatement(newstatement,code);
|
|
addstatement(newstatement,exitlabel_asmnode);
|
|
addstatement(newstatement,bodyexitcode);
|
|
addstatement(newstatement,final_asmnode);
|
|
end;
|
|
do_firstpass(newblock);
|
|
code:=newblock;
|
|
aktfilepos:=oldfilepos;
|
|
end;
|
|
|
|
|
|
procedure clearrefs(p : tnamedindexitem;arg:pointer);
|
|
begin
|
|
if (tsym(p).typ in [localvarsym,paravarsym,globalvarsym]) then
|
|
if tabstractvarsym(p).refs>1 then
|
|
tabstractvarsym(p).refs:=1;
|
|
end;
|
|
|
|
|
|
procedure check_for_stack(p : tnamedindexitem;arg:pointer);
|
|
begin
|
|
if tsym(p).typ=paravarsym then
|
|
begin
|
|
{ check if there no parameter of the current procedure is stack dependend }
|
|
if is_open_array(tparavarsym(p).vartype.def) or
|
|
is_array_of_const(tparavarsym(p).vartype.def) then
|
|
pboolean(arg)^:=true;
|
|
if assigned(p) and
|
|
assigned(tparavarsym(p).paraloc[calleeside].location) and
|
|
(tparavarsym(p).paraloc[calleeside].location^.loc=LOC_REFERENCE) then
|
|
pboolean(arg)^:=true;
|
|
end;
|
|
end;
|
|
|
|
|
|
function tcgprocinfo.stack_tainting_parameter : boolean;
|
|
begin
|
|
result:=false;
|
|
procdef.parast.foreach_static(@check_for_stack,@result);
|
|
end;
|
|
|
|
|
|
function tcgprocinfo.has_assembler_child : boolean;
|
|
var
|
|
hp : tcgprocinfo;
|
|
begin
|
|
result:=false;
|
|
hp:=tcgprocinfo(nestedprocs.first);
|
|
while assigned(hp) do
|
|
begin
|
|
if (hp.flags*[pi_has_assembler_block,pi_is_assembler])<>[] then
|
|
begin
|
|
result:=true;
|
|
exit;
|
|
end;
|
|
hp:=tcgprocinfo(hp.next);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.generate_code;
|
|
var
|
|
oldprocinfo : tprocinfo;
|
|
oldaktmaxfpuregisters : longint;
|
|
oldfilepos : tfileposinfo;
|
|
templist : Taasmoutput;
|
|
headertai : tai;
|
|
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;
|
|
|
|
{ We need valid code }
|
|
if Errorcount<>0 then
|
|
exit;
|
|
|
|
{ No code can be generated for generic template }
|
|
if (df_generic in procdef.defoptions) then
|
|
internalerror(200511152);
|
|
|
|
{ The RA and Tempgen shall not be available yet }
|
|
if assigned(tg) then
|
|
internalerror(200309201);
|
|
|
|
oldprocinfo:=current_procinfo;
|
|
oldfilepos:=aktfilepos;
|
|
oldaktmaxfpuregisters:=aktmaxfpuregisters;
|
|
|
|
current_procinfo:=self;
|
|
aktfilepos:=entrypos;
|
|
|
|
{ get new labels }
|
|
aktbreaklabel:=nil;
|
|
aktcontinuelabel:=nil;
|
|
templist:=Taasmoutput.create;
|
|
|
|
{ add parast/localst to symtablestack }
|
|
add_to_symtablestack;
|
|
|
|
{ when size optimization only count occurrence }
|
|
if cs_littlesize in aktglobalswitches then
|
|
cg.t_times:=1
|
|
else
|
|
{ reference for repetition is 100 }
|
|
cg.t_times:=100;
|
|
|
|
{ clear register count }
|
|
symtablestack.foreach_static(@clearrefs,nil);
|
|
symtablestack.next.foreach_static(@clearrefs,nil);
|
|
|
|
{ there's always a call to FPC_INITIALIZEUNITS/FPC_DO_EXIT in the main program }
|
|
if (procdef.localst.symtablelevel=main_program_level) and
|
|
(not current_module.is_unit) then
|
|
include(flags,pi_do_call);
|
|
|
|
{ set implicit_finally flag when there are locals/paras to be finalized }
|
|
current_procinfo.procdef.parast.foreach_static(@check_finalize_paras,nil);
|
|
current_procinfo.procdef.localst.foreach_static(@check_finalize_locals,nil);
|
|
|
|
{ firstpass everything }
|
|
flowcontrol:=[];
|
|
do_firstpass(code);
|
|
if code.registersfpu>0 then
|
|
include(current_procinfo.flags,pi_uses_fpu);
|
|
|
|
{ add implicit entry and exit code }
|
|
add_entry_exit_code;
|
|
|
|
{ only do secondpass if there are no errors }
|
|
if (ErrorCount=0) then
|
|
begin
|
|
{ set the start offset to the start of the temp area in the stack }
|
|
tg:=ttgobj.create;
|
|
|
|
{$ifdef x86}
|
|
{ try to strip the stack frame }
|
|
{ set the framepointer to esp if:
|
|
- no assembler directive, those are handled elsewhere
|
|
- no exceptions are used
|
|
- no debug info
|
|
- no pushes are used/esp modifications, could be:
|
|
* outgoing parameters on the stack
|
|
* incoming parameters on the stack
|
|
* open arrays
|
|
- no inline assembler
|
|
}
|
|
if (cs_optimize in aktglobalswitches) and
|
|
not(po_assembler in procdef.procoptions) and
|
|
((flags*[pi_has_assembler_block,pi_uses_exceptions,pi_is_assembler,
|
|
pi_needs_implicit_finally,pi_has_implicit_finally,pi_has_stackparameter])=[]) then
|
|
begin
|
|
{ we need the parameter info here to determine if the procedure gets
|
|
parameters on the stack
|
|
|
|
calling generate_parameter_info doesn't hurt but it costs time
|
|
}
|
|
generate_parameter_info;
|
|
if not(stack_tainting_parameter) and
|
|
not(has_assembler_child) then
|
|
begin
|
|
{ Only need to set the framepointer }
|
|
framepointer:=NR_STACK_POINTER_REG;
|
|
tg.direction:=1;
|
|
end;
|
|
end;
|
|
{$endif x86}
|
|
|
|
{ Create register allocator }
|
|
cg.init_register_allocators;
|
|
|
|
set_first_temp_offset;
|
|
generate_parameter_info;
|
|
|
|
{ Allocate space in temp/registers for parast and localst }
|
|
aktfilepos:=entrypos;
|
|
gen_alloc_symtable(aktproccode,procdef.parast);
|
|
gen_alloc_symtable(aktproccode,procdef.localst);
|
|
|
|
{ Store temp offset for information about 'real' temps }
|
|
tempstart:=tg.lasttemp;
|
|
|
|
{ Generate code to load register parameters in temps and insert local
|
|
copies for values parameters. This must be done before the code for the
|
|
body is generated because the localloc is updated.
|
|
Note: The generated code will be inserted after the code generation of
|
|
the body is finished, because only then the position is known }
|
|
{$ifdef oldregvars}
|
|
assign_regvars(code);
|
|
{$endif oldreg}
|
|
aktfilepos:=entrypos;
|
|
gen_load_para_value(templist);
|
|
|
|
{ caller paraloc info is also necessary in the stackframe_entry
|
|
code of the ppc (and possibly other processors) }
|
|
if not procdef.has_paraloc_info then
|
|
begin
|
|
procdef.requiredargarea:=paramanager.create_paraloc_info(procdef,callerside);
|
|
procdef.has_paraloc_info:=true;
|
|
end;
|
|
|
|
|
|
{ generate code for the node tree }
|
|
do_secondpass(code);
|
|
aktproccode.concatlist(exprasmlist);
|
|
{$ifdef i386}
|
|
procdef.fpu_used:=code.registersfpu;
|
|
{$endif i386}
|
|
|
|
{ The position of the loadpara_asmnode is now known }
|
|
aktproccode.insertlistafter(loadpara_asmnode.currenttai,templist);
|
|
|
|
{ first generate entry and initialize code with the correct
|
|
position and switches }
|
|
aktfilepos:=entrypos;
|
|
aktlocalswitches:=entryswitches;
|
|
|
|
cg.set_regalloc_extend_backwards(true);
|
|
|
|
gen_entry_code(templist);
|
|
aktproccode.insertlistafter(entry_asmnode.currenttai,templist);
|
|
gen_initialize_code(templist);
|
|
aktproccode.insertlistafter(init_asmnode.currenttai,templist);
|
|
|
|
{ now generate finalize and exit code with the correct position
|
|
and switches }
|
|
aktfilepos:=exitpos;
|
|
aktlocalswitches:=exitswitches;
|
|
|
|
cg.set_regalloc_extend_backwards(false);
|
|
|
|
gen_finalize_code(templist);
|
|
{ the finalcode must be concated if there was no position available,
|
|
using insertlistafter will result in an insert at the start
|
|
when currentai=nil }
|
|
if assigned(final_asmnode.currenttai) then
|
|
aktproccode.insertlistafter(final_asmnode.currenttai,templist)
|
|
else
|
|
aktproccode.concatlist(templist);
|
|
{ insert exit label at the correct position }
|
|
cg.a_label(templist,aktexitlabel);
|
|
if assigned(exitlabel_asmnode.currenttai) then
|
|
aktproccode.insertlistafter(exitlabel_asmnode.currenttai,templist)
|
|
else
|
|
aktproccode.concatlist(templist);
|
|
{ exit code }
|
|
gen_exit_code(templist);
|
|
aktproccode.concatlist(templist);
|
|
|
|
{$ifdef OLDREGVARS}
|
|
{ note: this must be done only after as much code as possible has }
|
|
{ been generated. The result is that when you ungetregister() a }
|
|
{ regvar, it will actually free the regvar (and alse free the }
|
|
{ the regvars at the same time). Doing this too early will }
|
|
{ confuse the register allocator, as the regvars will still be }
|
|
{ used. It should be done before loading the result regs (so }
|
|
{ they don't conflict with the regvars) and before }
|
|
{ gen_entry_code (that one has to be able to allocate the }
|
|
{ regvars again) (JM) }
|
|
free_regvars(aktproccode);
|
|
{$endif OLDREGVARS}
|
|
|
|
{ generate symbol and save end of header position }
|
|
aktfilepos:=entrypos;
|
|
gen_proc_symbol(templist);
|
|
headertai:=tai(templist.last);
|
|
{ insert symbol }
|
|
aktproccode.insertlist(templist);
|
|
|
|
{ Free space in temp/registers for parast and localst, must be
|
|
done after gen_entry_code }
|
|
aktfilepos:=exitpos;
|
|
gen_free_symtable(aktproccode,procdef.localst);
|
|
gen_free_symtable(aktproccode,procdef.parast);
|
|
|
|
{ add code that will load the return value, this is not done
|
|
for assembler routines when they didn't reference the result
|
|
variable }
|
|
gen_load_return_value(templist);
|
|
aktproccode.concatlist(templist);
|
|
|
|
{ Already reserve all registers for stack checking code and
|
|
generate the call to the helper function }
|
|
if (cs_check_stack in entryswitches) and
|
|
not(po_assembler in procdef.procoptions) and
|
|
(current_procinfo.procdef.proctypeoption<>potype_proginit) then
|
|
begin
|
|
aktfilepos:=entrypos;
|
|
gen_stack_check_call(templist);
|
|
aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist)
|
|
end;
|
|
|
|
{ load got if necessary }
|
|
cg.set_regalloc_extend_backwards(true);
|
|
aktfilepos:=entrypos;
|
|
gen_got_load(templist);
|
|
aktproccode.insertlistafter(headertai,templist);
|
|
|
|
cg.set_regalloc_extend_backwards(false);
|
|
|
|
{ The procedure body is finished, we can now
|
|
allocate the registers }
|
|
cg.do_register_allocation(aktproccode,headertai);
|
|
|
|
{ Add save and restore of used registers }
|
|
aktfilepos:=entrypos;
|
|
gen_save_used_regs(templist);
|
|
aktproccode.insertlistafter(headertai,templist);
|
|
aktfilepos:=exitpos;
|
|
gen_restore_used_regs(aktproccode);
|
|
{ We know the size of the stack, now we can generate the
|
|
parameter that is passed to the stack checking code }
|
|
if (cs_check_stack in entryswitches) and
|
|
not(po_assembler in procdef.procoptions) and
|
|
(current_procinfo.procdef.proctypeoption<>potype_proginit) then
|
|
begin
|
|
aktfilepos:=entrypos;
|
|
gen_stack_check_size_para(templist);
|
|
aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist)
|
|
end;
|
|
{ Add entry code (stack allocation) after header }
|
|
aktfilepos:=entrypos;
|
|
gen_proc_entry_code(templist);
|
|
aktproccode.insertlistafter(headertai,templist);
|
|
{ Add exit code at the end }
|
|
aktfilepos:=exitpos;
|
|
gen_proc_exit_code(templist);
|
|
aktproccode.concatlist(templist);
|
|
|
|
{ check if the implicit finally has been generated. The flag
|
|
should already be set in pass1 }
|
|
if (cs_implicit_exceptions in aktmoduleswitches) and
|
|
not(procdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) and
|
|
(pi_needs_implicit_finally in flags) and
|
|
not(pi_has_implicit_finally in flags) then
|
|
internalerror(200405231);
|
|
|
|
{$ifndef NoOpt}
|
|
if not(cs_no_regalloc in aktglobalswitches) then
|
|
begin
|
|
if (cs_optimize in aktglobalswitches) and
|
|
{ do not optimize pure assembler procedures }
|
|
not(pi_is_assembler in flags) then
|
|
optimize(aktproccode);
|
|
end;
|
|
{$endif NoOpt}
|
|
|
|
{ Add end symbol and debug info }
|
|
aktfilepos:=exitpos;
|
|
gen_proc_symbol_end(templist);
|
|
aktproccode.concatlist(templist);
|
|
|
|
{$ifdef ARM}
|
|
{ because of the limited constant size of the arm, all data access is done pc relative }
|
|
insertpcrelativedata(aktproccode,aktlocaldata);
|
|
{$endif ARM}
|
|
|
|
{$ifdef POWERPC}
|
|
fixup_jmps(aktproccode);
|
|
{$endif POWERPC}
|
|
{$ifdef POWERPC64}
|
|
fixup_jmps(aktproccode);
|
|
{$endif POWERPC64}
|
|
{ insert line debuginfo }
|
|
if (cs_debuginfo in aktmoduleswitches) or
|
|
(cs_use_lineinfo in aktglobalswitches) then
|
|
debuginfo.insertlineinfo(aktproccode);
|
|
|
|
{ add the procedure to the al_procedures }
|
|
maybe_new_object_file(asmlist[al_procedures]);
|
|
new_section(asmlist[al_procedures],sec_code,lower(procdef.mangledname),getprocalign);
|
|
asmlist[al_procedures].concatlist(aktproccode);
|
|
{ save local data (casetable) also in the same file }
|
|
if assigned(aktlocaldata) and
|
|
(not aktlocaldata.empty) then
|
|
asmlist[al_procedures].concatlist(aktlocaldata);
|
|
|
|
{ only now we can remove the temps }
|
|
tg.resettempgen;
|
|
|
|
{ stop tempgen and ra }
|
|
tg.free;
|
|
cg.done_register_allocators;
|
|
tg:=nil;
|
|
end;
|
|
|
|
{ restore symtablestack }
|
|
remove_from_symtablestack;
|
|
|
|
{ restore }
|
|
templist.free;
|
|
aktmaxfpuregisters:=oldaktmaxfpuregisters;
|
|
aktfilepos:=oldfilepos;
|
|
current_procinfo:=oldprocinfo;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.add_to_symtablestack;
|
|
var
|
|
_class,hp : tobjectdef;
|
|
begin
|
|
{ allocate the symbol for this procedure }
|
|
alloc_proc_symbol(procdef);
|
|
|
|
{ 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
|
|
{ remove code tree, if not inline procedure }
|
|
if assigned(code) then
|
|
begin
|
|
{ the inline procedure has already got a copy of the tree
|
|
stored in procdef.inlininginfo }
|
|
code.free;
|
|
code:=nil;
|
|
end;
|
|
end;
|
|
|
|
|
|
function checknodeinlining(procdef: tprocdef): boolean;
|
|
var
|
|
i : integer;
|
|
currpara : tparavarsym;
|
|
begin
|
|
result := false;
|
|
if (pi_has_assembler_block in current_procinfo.flags) then
|
|
exit;
|
|
for i:=0 to procdef.paras.count-1 do
|
|
begin
|
|
currpara:=tparavarsym(procdef.paras[i]);
|
|
{ we can't handle formaldefs and special arrays (the latter may need a }
|
|
{ re-basing of the index, i.e. if you pass an array[1..10] as open array, }
|
|
{ you have to add 1 to all index operations if you directly inline it }
|
|
if ((currpara.varspez in [vs_out,vs_var,vs_const]) and
|
|
(currpara.vartype.def.deftype=formaldef)) or
|
|
is_special_array(currpara.vartype.def) then
|
|
exit;
|
|
end;
|
|
result:=true;
|
|
end;
|
|
|
|
|
|
procedure tcgprocinfo.parse_body;
|
|
var
|
|
oldprocinfo : tprocinfo;
|
|
oldblock_type : tblock_type;
|
|
oldconstsymtable : tsymtable;
|
|
st : tsymtable;
|
|
begin
|
|
oldprocinfo:=current_procinfo;
|
|
oldblock_type:=block_type;
|
|
oldconstsymtable:=constsymtable;
|
|
|
|
{ reset break and continue labels }
|
|
block_type:=bt_body;
|
|
|
|
current_procinfo:=self;
|
|
|
|
{ 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;
|
|
|
|
{$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;
|
|
|
|
if (df_generic in procdef.defoptions) then
|
|
begin
|
|
{ start token recorder for generic template }
|
|
procdef.initgeneric;
|
|
current_scanner.startrecordtokens(procdef.generictokenbuf);
|
|
end;
|
|
|
|
{ parse the code ... }
|
|
code:=block(current_module.islibrary);
|
|
|
|
if (df_generic in procdef.defoptions) then
|
|
begin
|
|
{ stop token recorder for generic template }
|
|
current_scanner.stoprecordtokens;
|
|
|
|
{ Give a warning for accesses in the static symtable that aren't visible
|
|
outside the current unit }
|
|
st:=procdef.owner;
|
|
while (st.symtabletype=objectsymtable) do
|
|
st:=st.defowner.owner;
|
|
if (pi_uses_static_symtable in flags) and
|
|
(st.symtabletype<>staticsymtable) then
|
|
Comment(V_Warning,'Global Generic template references static symtable');
|
|
end;
|
|
|
|
{ save exit info }
|
|
exitswitches:=aktlocalswitches;
|
|
exitpos:=last_endtoken_filepos;
|
|
|
|
{ the procedure is now defined }
|
|
procdef.forwarddef:=false;
|
|
|
|
if assigned(code) then
|
|
begin
|
|
{ get a better entry point }
|
|
entrypos:=code.fileinfo;
|
|
|
|
{ Finish type checking pass }
|
|
do_resulttypepass(code);
|
|
end;
|
|
|
|
{ Check for unused labels, forwards, symbols for procedures. Static
|
|
symtable is checked in pmodules.
|
|
The check must be done after the resulttypepass }
|
|
if (Errorcount=0) and
|
|
(tstoredsymtable(procdef.localst).symtabletype<>staticsymtable) 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;
|
|
{ check for unused symbols, but only if there is no asm block }
|
|
if not(pi_has_assembler_block in flags) then
|
|
begin
|
|
tstoredsymtable(procdef.localst).allsymbolsused;
|
|
tstoredsymtable(procdef.parast).allsymbolsused;
|
|
end;
|
|
end;
|
|
|
|
if (po_inline in procdef.procoptions) then
|
|
begin
|
|
{ Can we inline this procedure? }
|
|
if checknodeinlining(procdef) then
|
|
begin
|
|
new(procdef.inlininginfo);
|
|
include(procdef.procoptions,po_has_inlininginfo);
|
|
procdef.inlininginfo^.code:=code.getcopy;
|
|
procdef.inlininginfo^.flags:=current_procinfo.flags;
|
|
{ The blocknode needs to set an exit label }
|
|
if procdef.inlininginfo^.code.nodetype=blockn then
|
|
include(procdef.inlininginfo^.code.flags,nf_block_with_exit);
|
|
end;
|
|
end;
|
|
|
|
{ Print the node to tree.log }
|
|
if paraprintnodetree=1 then
|
|
printproc;
|
|
|
|
{ ... remove symbol tables }
|
|
remove_from_symtablestack;
|
|
|
|
{$ifdef state_tracking}
|
|
{ aktstate.destroy;}
|
|
{$endif state_tracking}
|
|
|
|
{ reset to normal non static function }
|
|
if (procdef.parast.symtablelevel=normal_function_level) then
|
|
allow_only_static:=false;
|
|
current_procinfo:=oldprocinfo;
|
|
|
|
{ Restore old state }
|
|
constsymtable:=oldconstsymtable;
|
|
block_type:=oldblock_type;
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
PROCEDURE/FUNCTION PARSING
|
|
****************************************************************************}
|
|
|
|
|
|
procedure check_init_paras(p:tnamedindexitem;arg:pointer);
|
|
begin
|
|
if tsym(p).typ<>paravarsym then
|
|
exit;
|
|
with tparavarsym(p) do
|
|
if (not is_class(vartype.def) and
|
|
vartype.def.needs_inittable and
|
|
(varspez in [vs_value,vs_out])) then
|
|
include(current_procinfo.flags,pi_do_call);
|
|
end;
|
|
|
|
|
|
|
|
procedure read_proc_body(old_current_procinfo:tprocinfo;pd:tprocdef);
|
|
{
|
|
Parses the procedure directives, then parses the procedure body, then
|
|
generates the code for it
|
|
}
|
|
|
|
procedure do_generate_code(pi:tcgprocinfo);
|
|
var
|
|
hpi : tcgprocinfo;
|
|
begin
|
|
{ generate code for this procedure }
|
|
pi.generate_code;
|
|
{ process nested procs }
|
|
hpi:=tcgprocinfo(pi.nestedprocs.first);
|
|
while assigned(hpi) do
|
|
begin
|
|
do_generate_code(hpi);
|
|
hpi:=tcgprocinfo(hpi.next);
|
|
end;
|
|
pi.resetprocdef;
|
|
end;
|
|
|
|
var
|
|
oldfailtokenmode : tmodeswitch;
|
|
isnestedproc : boolean;
|
|
begin
|
|
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);
|
|
|
|
{ Handle Export of this procedure }
|
|
if (po_exports in pd.procoptions) and
|
|
(target_info.system in [system_i386_os2,system_i386_emx]) then
|
|
begin
|
|
pd.aliasnames.insert(pd.procsym.realname);
|
|
if cs_link_deffile in aktglobalswitches then
|
|
deffile.AddExport(pd.mangledname);
|
|
end;
|
|
|
|
{ Insert result variables in the localst }
|
|
insert_funcret_local(pd);
|
|
|
|
{ check if there are para's which require initing -> set }
|
|
{ pi_do_call (if not yet set) }
|
|
if not(pi_do_call in current_procinfo.flags) then
|
|
pd.parast.foreach_static(@check_init_paras,nil);
|
|
|
|
{ set _FAIL as keyword if constructor }
|
|
if (pd.proctypeoption=potype_constructor) then
|
|
begin
|
|
oldfailtokenmode:=tokeninfo^[_FAIL].keyword;
|
|
tokeninfo^[_FAIL].keyword:=m_all;
|
|
end;
|
|
|
|
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
|
|
begin
|
|
{ We can't support inlining for procedures that have nested
|
|
procedures because the nested procedures use a fixed offset
|
|
for accessing locals in the parent procedure (PFV) }
|
|
if (tcgprocinfo(current_procinfo).nestedprocs.count>0) then
|
|
begin
|
|
if (df_generic in current_procinfo.procdef.defoptions) then
|
|
{$warning TODO Add error message for nested procs in generics}
|
|
internalerror(200511151)
|
|
else if (po_inline in current_procinfo.procdef.procoptions) then
|
|
begin
|
|
Message1(parser_w_not_supported_for_inline,'nested procedures');
|
|
Message(parser_w_inlining_disabled);
|
|
current_procinfo.procdef.proccalloption:=pocall_default;
|
|
end;
|
|
end;
|
|
if not(df_generic in current_procinfo.procdef.defoptions) then
|
|
do_generate_code(tcgprocinfo(current_procinfo));
|
|
end;
|
|
|
|
{ reset _FAIL as _SELF normal }
|
|
if (pd.proctypeoption=potype_constructor) then
|
|
tokeninfo^[_FAIL].keyword:=oldfailtokenmode;
|
|
|
|
{ release procinfo }
|
|
if tprocinfo(current_module.procinfo)<>current_procinfo then
|
|
internalerror(200304274);
|
|
current_module.procinfo:=current_procinfo.parent;
|
|
|
|
{ For specialization we didn't record the last semicolon. Moving this parsing
|
|
into the parse_body routine is not done because of having better file position
|
|
information available }
|
|
if not(df_specialization in current_procinfo.procdef.defoptions) then
|
|
consume(_SEMICOLON);
|
|
|
|
if not isnestedproc then
|
|
current_procinfo.free;
|
|
end;
|
|
|
|
|
|
procedure read_proc;
|
|
{
|
|
Parses the procedure directives, then parses the procedure body, then
|
|
generates the code for it
|
|
}
|
|
|
|
procedure do_generate_code(pi:tcgprocinfo);
|
|
var
|
|
hpi : tcgprocinfo;
|
|
begin
|
|
{ generate code for this procedure }
|
|
pi.generate_code;
|
|
{ process nested procs }
|
|
hpi:=tcgprocinfo(pi.nestedprocs.first);
|
|
while assigned(hpi) do
|
|
begin
|
|
do_generate_code(hpi);
|
|
hpi:=tcgprocinfo(hpi.next);
|
|
end;
|
|
pi.resetprocdef;
|
|
end;
|
|
|
|
var
|
|
old_current_procinfo : tprocinfo;
|
|
pdflags : tpdflags;
|
|
pd : tprocdef;
|
|
s : string;
|
|
begin
|
|
{ save old state }
|
|
old_current_procinfo:=current_procinfo;
|
|
|
|
{ reset current_procinfo.procdef to nil to be sure that nothing is writing
|
|
to an other procdef }
|
|
current_procinfo:=nil;
|
|
|
|
{ parse procedure declaration }
|
|
if assigned(old_current_procinfo) and
|
|
assigned(old_current_procinfo.procdef) then
|
|
pd:=parse_proc_dec(old_current_procinfo.procdef._class)
|
|
else
|
|
pd:=parse_proc_dec(nil);
|
|
|
|
{ set the default function options }
|
|
if parse_only then
|
|
begin
|
|
pd.forwarddef:=true;
|
|
{ set also the interface flag, for better error message when the
|
|
implementation doesn't much this header }
|
|
pd.interfacedef:=true;
|
|
include(pd.procoptions,po_global);
|
|
pdflags:=[pd_interface];
|
|
end
|
|
else
|
|
begin
|
|
pdflags:=[pd_body];
|
|
if (not current_module.in_interface) then
|
|
include(pdflags,pd_implemen);
|
|
if (not current_module.is_unit) or
|
|
maybe_smartlink_symbol or
|
|
{
|
|
taking addresses of static procedures goes wrong
|
|
if they aren't global when pic is used (FK)
|
|
}
|
|
(cs_create_pic in aktmoduleswitches) then
|
|
include(pd.procoptions,po_global);
|
|
pd.forwarddef:=false;
|
|
end;
|
|
|
|
{ parse the directives that may follow }
|
|
parse_proc_directives(pd,pdflags);
|
|
|
|
{ hint directives, these can be separated by semicolons here,
|
|
that needs to be handled here with a loop (PFV) }
|
|
while try_consume_hintdirective(pd.symoptions) do
|
|
Consume(_SEMICOLON);
|
|
|
|
{ Set calling convention }
|
|
handle_calling_convention(pd);
|
|
|
|
{ search for forward declarations }
|
|
if not proc_add_definition(pd) then
|
|
begin
|
|
{ A method must be forward defined (in the object declaration) }
|
|
if assigned(pd._class) and
|
|
(not assigned(old_current_procinfo.procdef._class)) then
|
|
begin
|
|
MessagePos1(pd.fileinfo,parser_e_header_dont_match_any_member,pd.fullprocname(false));
|
|
tprocsym(pd.procsym).write_parameter_lists(pd);
|
|
end
|
|
else
|
|
begin
|
|
{ Give a better error if there is a forward def in the interface and only
|
|
a single implementation }
|
|
if (not pd.forwarddef) and
|
|
(not pd.interfacedef) and
|
|
(tprocsym(pd.procsym).procdef_count>1) and
|
|
tprocsym(pd.procsym).first_procdef.forwarddef and
|
|
tprocsym(pd.procsym).first_procdef.interfacedef and
|
|
not(tprocsym(pd.procsym).procdef_count>2) then
|
|
begin
|
|
MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false));
|
|
tprocsym(pd.procsym).write_parameter_lists(pd);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ Set mangled name }
|
|
proc_set_mangledname(pd);
|
|
|
|
{ compile procedure when a body is needed }
|
|
if (pd_body in pdflags) then
|
|
begin
|
|
read_proc_body(old_current_procinfo,pd);
|
|
end
|
|
else
|
|
begin
|
|
{ Handle imports }
|
|
if (po_external in pd.procoptions) then
|
|
begin
|
|
{ External declared in implementation, and there was already a
|
|
forward (or interface) declaration then we need to generate
|
|
a stub that calls the external routine }
|
|
if (not pd.forwarddef) and
|
|
(pd.hasforward) and
|
|
not(
|
|
assigned(pd.import_dll) and
|
|
(target_info.system in [system_i386_win32,system_i386_wdosx,
|
|
system_i386_emx,system_i386_os2,system_arm_wince,system_i386_wince])
|
|
) then
|
|
begin
|
|
s:=proc_get_importname(pd);
|
|
if s<>'' then
|
|
gen_external_stub(asmlist[al_procedures],pd,{$IFDEF POWERPC64}'.'+{$ENDIF}s);
|
|
end;
|
|
|
|
{ Import DLL specified? }
|
|
if assigned(pd.import_dll) then
|
|
begin
|
|
{ create importlib if not already done }
|
|
if not(current_module.uses_imports) then
|
|
begin
|
|
current_module.uses_imports:=true;
|
|
importlib.preparelib(current_module.realmodulename^);
|
|
end;
|
|
|
|
if assigned(pd.import_name) then
|
|
importlib.importprocedure(pd,pd.import_dll^,pd.import_nr,pd.import_name^)
|
|
else
|
|
importlib.importprocedure(pd,pd.import_dll^,pd.import_nr,'');
|
|
end
|
|
else
|
|
begin
|
|
{ add import name to external list for DLL scanning }
|
|
if tf_has_dllscanner in target_info.flags then
|
|
current_module.externals.insert(tExternalsItem.create(proc_get_importname(pd)));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ make sure that references to forward-declared functions are not }
|
|
{ treated as references to external symbols, needed for darwin. }
|
|
|
|
{ make sure we don't change the binding of real external symbols }
|
|
if not(po_external in pd.procoptions) then
|
|
begin
|
|
if (po_global in pd.procoptions) or
|
|
(cs_profile in aktmoduleswitches) then
|
|
objectlibrary.newasmsymbol(pd.mangledname,AB_GLOBAL,AT_FUNCTION)
|
|
else
|
|
objectlibrary.newasmsymbol(pd.mangledname,AB_LOCAL,AT_FUNCTION);
|
|
end;
|
|
|
|
current_procinfo:=old_current_procinfo;
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
DECLARATION PARSING
|
|
****************************************************************************}
|
|
|
|
{ search in symtablestack for not complete classes }
|
|
procedure check_forward_class(p : tnamedindexitem;arg:pointer);
|
|
begin
|
|
if (tsym(p).typ=typesym) and
|
|
(ttypesym(p).restype.def.deftype=objectdef) and
|
|
(oo_is_forward in tobjectdef(ttypesym(p).restype.def).objectoptions) then
|
|
MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname);
|
|
end;
|
|
|
|
|
|
procedure read_declarations(islibrary : boolean);
|
|
begin
|
|
repeat
|
|
if not assigned(current_procinfo) then
|
|
internalerror(200304251);
|
|
case token of
|
|
_LABEL:
|
|
label_dec;
|
|
_CONST:
|
|
const_dec;
|
|
_TYPE:
|
|
type_dec;
|
|
_VAR:
|
|
var_dec;
|
|
_THREADVAR:
|
|
threadvar_dec;
|
|
_CONSTRUCTOR,
|
|
_DESTRUCTOR,
|
|
_FUNCTION,
|
|
_PROCEDURE,
|
|
_OPERATOR,
|
|
_CLASS:
|
|
read_proc;
|
|
_EXPORTS:
|
|
begin
|
|
if not(assigned(current_procinfo.procdef.localst)) or
|
|
(current_procinfo.procdef.localst.symtablelevel>main_program_level) then
|
|
begin
|
|
Message(parser_e_syntax_error);
|
|
consume_all_until(_SEMICOLON);
|
|
end
|
|
else if islibrary or
|
|
(target_info.system in system_unit_program_exports) then
|
|
read_exports
|
|
else
|
|
begin
|
|
Message(parser_w_unsupported_feature);
|
|
consume(_BEGIN);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
case idtoken of
|
|
_RESOURCESTRING :
|
|
begin
|
|
{ m_class is needed, because the resourcestring
|
|
loading is in the ObjPas unit }
|
|
if (m_class in aktmodeswitches) then
|
|
resourcestring_dec
|
|
else
|
|
break;
|
|
end;
|
|
_PROPERTY:
|
|
begin
|
|
if (m_fpc in aktmodeswitches) then
|
|
property_dec
|
|
else
|
|
break;
|
|
end;
|
|
else
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
until false;
|
|
|
|
{ check for incomplete class definitions, this is only required
|
|
for fpc modes }
|
|
if (m_fpc in aktmodeswitches) then
|
|
symtablestack.foreach_static(@check_forward_class,nil);
|
|
end;
|
|
|
|
|
|
procedure read_interface_declarations;
|
|
begin
|
|
repeat
|
|
case token of
|
|
_CONST :
|
|
const_dec;
|
|
_TYPE :
|
|
type_dec;
|
|
_VAR :
|
|
var_dec;
|
|
_THREADVAR :
|
|
threadvar_dec;
|
|
_FUNCTION,
|
|
_PROCEDURE,
|
|
_OPERATOR :
|
|
read_proc;
|
|
else
|
|
begin
|
|
case idtoken of
|
|
_RESOURCESTRING :
|
|
resourcestring_dec;
|
|
_PROPERTY:
|
|
begin
|
|
if (m_fpc in aktmodeswitches) then
|
|
property_dec
|
|
else
|
|
break;
|
|
end;
|
|
else
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
until false;
|
|
{ check for incomplete class definitions, this is only required
|
|
for fpc modes }
|
|
if (m_fpc in aktmodeswitches) then
|
|
symtablestack.foreach_static(@check_forward_class,nil);
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
SPECIALIZATION BODY GENERATION
|
|
****************************************************************************}
|
|
|
|
|
|
procedure specialize_objectdefs(p:tnamedindexitem;arg:pointer);
|
|
var
|
|
hp : tdef;
|
|
oldaktfilepos : tfileposinfo;
|
|
begin
|
|
if not((tsym(p).typ=typesym) and
|
|
(ttypesym(p).restype.def.deftype=objectdef) and
|
|
(df_specialization in ttypesym(p).restype.def.defoptions)
|
|
) then
|
|
exit;
|
|
|
|
{ definitions }
|
|
hp:=tdef(tobjectdef(ttypesym(p).restype.def).symtable.defindex.first);
|
|
while assigned(hp) do
|
|
begin
|
|
if hp.deftype=procdef then
|
|
begin
|
|
if not(
|
|
assigned(tprocdef(hp).genericdef) and
|
|
(tprocdef(hp).genericdef.deftype=procdef) and
|
|
assigned(tprocdef(tprocdef(hp).genericdef).generictokenbuf)
|
|
) then
|
|
internalerror(200512111);
|
|
oldaktfilepos:=aktfilepos;
|
|
aktfilepos:=tprocdef(tprocdef(hp).genericdef).fileinfo;
|
|
akttokenpos:=aktfilepos;
|
|
current_scanner.startreplaytokens(tprocdef(tprocdef(hp).genericdef).generictokenbuf);
|
|
read_proc_body(nil,tprocdef(hp));
|
|
aktfilepos:=oldaktfilepos;
|
|
end;
|
|
hp:=tdef(hp.indexnext);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure generate_specialization_procs;
|
|
var
|
|
oldsymtablestack : tsymtable;
|
|
begin
|
|
if assigned(current_module.globalsymtable) then
|
|
current_module.globalsymtable.foreach_static(@specialize_objectdefs,nil);
|
|
if assigned(current_module.localsymtable) then
|
|
begin
|
|
oldsymtablestack:=symtablestack;
|
|
current_module.localsymtable.next:=symtablestack;
|
|
symtablestack:=current_module.localsymtable;
|
|
current_module.localsymtable.foreach_static(@specialize_objectdefs,nil);
|
|
symtablestack:=oldsymtablestack;
|
|
end;
|
|
end;
|
|
|
|
end.
|