summaryrefslogtreecommitdiff
path: root/compiler/psub.pas
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/psub.pas')
-rw-r--r--compiler/psub.pas1475
1 files changed, 1475 insertions, 0 deletions
diff --git a/compiler/psub.pas b/compiler/psub.pas
new file mode 100644
index 0000000000..28e3fea805
--- /dev/null
+++ b/compiler/psub.pas
@@ -0,0 +1,1475 @@
+{
+ 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;
+ 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;
+
+
+
+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,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 tcgprocinfo.generate_code;
+ var
+ oldprocinfo : tprocinfo;
+ oldaktmaxfpuregisters : longint;
+ oldfilepos : tfileposinfo;
+ templist : Taasmoutput;
+ headertai : tai;
+ curralign : longint;
+ 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;
+
+ { 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;
+
+ { 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;
+ 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;
+ 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}
+
+ { 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);
+
+ { 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);
+
+ { 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;
+
+ { 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);
+
+ { gprof uses 16 byte granularity }
+ if (cs_profile in aktmoduleswitches) then
+ curralign:=16
+ else
+ curralign:=aktalignment.procalign;
+
+ { add the procedure to the al_procedures }
+ maybe_new_object_file(asmlist[al_procedures]);
+ new_section(asmlist[al_procedures],sec_code,lower(procdef.mangledname),curralign);
+ 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
+ { 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;
+ begin
+ oldprocinfo:=current_procinfo;
+ oldblock_type:=block_type;
+ { 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;
+
+ { parse the code ... }
+ code:=block(current_module.islibrary);
+ { 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;
+
+ 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;
+ {
+ 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;
+ oldconstsymtable : tsymtable;
+ oldfailtokenmode : tmodeswitch;
+ pdflags : tpdflags;
+ pd : tprocdef;
+ isnestedproc : boolean;
+ s : string;
+ begin
+ { save old state }
+ oldconstsymtable:=constsymtable;
+ 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 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
+ 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 (po_inline in current_procinfo.procdef.procoptions) and
+ (tcgprocinfo(current_procinfo).nestedprocs.count>0) then
+ begin
+ Message1(parser_w_not_supported_for_inline,'nested procedures');
+ Message(parser_w_inlining_disabled);
+ current_procinfo.procdef.proccalloption:=pocall_default;
+ end;
+ 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;
+ if not isnestedproc then
+ current_procinfo.free;
+
+ consume(_SEMICOLON);
+ 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 target_info.DllScanSupported then
+ current_module.externals.insert(tExternalsItem.create(proc_get_importname(pd)));
+ end;
+ end;
+ end;
+
+ { Restore old state }
+ constsymtable:=oldconstsymtable;
+
+ 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;
+
+
+end.
View Lorry Controller Status