mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-28 08:43:41 +02:00
912 lines
34 KiB
ObjectPascal
912 lines
34 KiB
ObjectPascal
{
|
|
$Id$
|
|
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
|
|
|
|
procedure compile_proc_body(make_global,parent_has_class:boolean);
|
|
|
|
{ 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,cclasses,
|
|
{ global }
|
|
globtype,globals,tokens,verbose,comphook,
|
|
systems,
|
|
{ aasm }
|
|
cpubase,cpuinfo,aasmbase,aasmtai,
|
|
{ symtable }
|
|
symconst,symbase,symdef,symsym,symtype,symtable,types,paramgr,
|
|
ppu,fmodule,
|
|
{ pass 1 }
|
|
node,
|
|
nbas,
|
|
pass_1,
|
|
{ pass 2 }
|
|
{$ifndef NOPASS2}
|
|
pass_2,
|
|
{$endif}
|
|
{ parser }
|
|
scanner,
|
|
pbase,pstatmnt,pdecl,pdecsub,pexports,
|
|
{ codegen }
|
|
tgobj,cgbase,rgobj,rgcpu,
|
|
ncgutil
|
|
{$ifndef NOOPT}
|
|
{$ifdef i386}
|
|
,aopt386
|
|
{$else i386}
|
|
,aoptcpu
|
|
{$endif i386}
|
|
{$endif}
|
|
;
|
|
|
|
|
|
{****************************************************************************
|
|
PROCEDURE/FUNCTION BODY PARSING
|
|
****************************************************************************}
|
|
|
|
function block(islibrary : boolean) : tnode;
|
|
var
|
|
storepos : tfileposinfo;
|
|
begin
|
|
{ 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(aktprocdef.procoptions,po_assembler);
|
|
|
|
{ Handle assembler block different }
|
|
if (po_assembler in aktprocdef.procoptions) then
|
|
begin
|
|
read_declarations(false);
|
|
block:=assembler_block;
|
|
exit;
|
|
end;
|
|
|
|
if not is_void(aktprocdef.rettype.def) then
|
|
begin
|
|
{ if the current is a function aktprocsym is non nil }
|
|
{ and there is a local symtable set }
|
|
storepos:=akttokenpos;
|
|
akttokenpos:=aktprocsym.fileinfo;
|
|
aktprocdef.funcretsym:=tfuncretsym.create(aktprocsym.name,aktprocdef.rettype);
|
|
{ insert in local symtable }
|
|
symtablestack.insert(aktprocdef.funcretsym);
|
|
akttokenpos:=storepos;
|
|
if paramanager.ret_in_acc(aktprocdef.rettype.def) or
|
|
(aktprocdef.rettype.def.deftype=floatdef) then
|
|
procinfo^.return_offset:=-tfuncretsym(aktprocdef.funcretsym).address;
|
|
{ insert result also if support is on }
|
|
if (m_result in aktmodeswitches) then
|
|
begin
|
|
aktprocdef.resultfuncretsym:=tfuncretsym.create('RESULT',aktprocdef.rettype);
|
|
symtablestack.insert(aktprocdef.resultfuncretsym);
|
|
end;
|
|
end;
|
|
read_declarations(islibrary);
|
|
|
|
{ temporary space is set, while the BEGIN of the procedure }
|
|
if (symtablestack.symtabletype=localsymtable) then
|
|
procinfo^.firsttemp_offset := -symtablestack.datasize
|
|
else
|
|
procinfo^.firsttemp_offset := 0;
|
|
|
|
{ space for the return value }
|
|
{ !!!!! this means that we can not set the return value
|
|
in a subfunction !!!!! }
|
|
{ because we don't know yet where the address is }
|
|
if not is_void(aktprocdef.rettype.def) then
|
|
begin
|
|
if paramanager.ret_in_acc(aktprocdef.rettype.def) or (aktprocdef.rettype.def.deftype=floatdef) then
|
|
begin
|
|
{ the space has been set in the local symtable }
|
|
procinfo^.return_offset:=-tfuncretsym(aktprocdef.funcretsym).address;
|
|
if ((procinfo^.flags and pi_operator)<>0) and
|
|
assigned(otsym) then
|
|
otsym.address:=-procinfo^.return_offset;
|
|
{ eax is modified by a function }
|
|
include(rg.usedinproc,accumulator);
|
|
if (sizeof(aword) < 8) and
|
|
(is_64bitint(aktprocdef.rettype.def)) then
|
|
include(rg.usedinproc,accumulatorhigh);
|
|
end;
|
|
end;
|
|
|
|
{Unit initialization?.}
|
|
if (lexlevel=unit_init_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
|
|
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
|
|
current_module.flags:=current_module.flags or uf_init;
|
|
block:=statement_block(_BEGIN);
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
block:=statement_block(_BEGIN);
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
PROCEDURE/FUNCTION COMPILING
|
|
****************************************************************************}
|
|
|
|
procedure compile_proc_body(make_global,parent_has_class:boolean);
|
|
{
|
|
Compile the body of a procedure
|
|
}
|
|
var
|
|
oldexitlabel,oldexit2label : tasmlabel;
|
|
oldfaillabel,oldquickexitlabel:tasmlabel;
|
|
_class,hp:tobjectdef;
|
|
{ switches can change inside the procedure }
|
|
entryswitches, exitswitches : tlocalswitches;
|
|
oldaktmaxfpuregisters,localmaxfpuregisters : longint;
|
|
{ code for the subroutine as tree }
|
|
code:tnode;
|
|
{ size of the local strackframe }
|
|
stackframe:longint;
|
|
{ true when no stackframe is required }
|
|
nostackframe:boolean;
|
|
{ number of bytes which have to be cleared by RET }
|
|
parasize:longint;
|
|
{ filepositions }
|
|
entrypos,
|
|
savepos,
|
|
exitpos : tfileposinfo;
|
|
begin
|
|
{ calculate the lexical level }
|
|
inc(lexlevel);
|
|
if lexlevel>32 then
|
|
Message(parser_e_too_much_lexlevel);
|
|
|
|
{ static is also important for local procedures !! }
|
|
if (po_staticmethod in aktprocdef.procoptions) then
|
|
allow_only_static:=true
|
|
else if (lexlevel=normal_function_level) then
|
|
allow_only_static:=false;
|
|
|
|
{ save old labels }
|
|
oldexitlabel:=aktexitlabel;
|
|
oldexit2label:=aktexit2label;
|
|
oldquickexitlabel:=quickexitlabel;
|
|
oldfaillabel:=faillabel;
|
|
{ get new labels }
|
|
getlabel(aktexitlabel);
|
|
getlabel(aktexit2label);
|
|
{ exit for fail in constructors }
|
|
if (aktprocdef.proctypeoption=potype_constructor) then
|
|
begin
|
|
getlabel(faillabel);
|
|
getlabel(quickexitlabel);
|
|
end;
|
|
{ reset break and continue labels }
|
|
block_type:=bt_general;
|
|
aktbreaklabel:=nil;
|
|
aktcontinuelabel:=nil;
|
|
|
|
{ insert symtables for the class, by only if it is no nested function }
|
|
if assigned(procinfo^._class) and not(parent_has_class) then
|
|
begin
|
|
{ insert them in the reverse order ! }
|
|
hp:=nil;
|
|
repeat
|
|
_class:=procinfo^._class;
|
|
while _class.childof<>hp do
|
|
_class:=_class.childof;
|
|
hp:=_class;
|
|
_class.symtable.next:=symtablestack;
|
|
symtablestack:=_class.symtable;
|
|
until hp=procinfo^._class;
|
|
end;
|
|
|
|
{ insert parasymtable in symtablestack}
|
|
{ only if lexlevel > 1 !!! global symtable should be right after staticsymtazble
|
|
for checking of same names used in interface and implementation !! }
|
|
if lexlevel>=normal_function_level then
|
|
begin
|
|
aktprocdef.parast.next:=symtablestack;
|
|
symtablestack:=aktprocdef.parast;
|
|
symtablestack.symtablelevel:=lexlevel;
|
|
end;
|
|
{ insert localsymtable in symtablestack}
|
|
aktprocdef.localst.next:=symtablestack;
|
|
symtablestack:=aktprocdef.localst;
|
|
symtablestack.symtablelevel:=lexlevel;
|
|
{ constant symbols are inserted in this symboltable }
|
|
constsymtable:=symtablestack;
|
|
|
|
{ reset the temporary memory }
|
|
rg.cleartempgen;
|
|
rg.usedinproc:=[];
|
|
|
|
{ save entry info }
|
|
entrypos:=aktfilepos;
|
|
entryswitches:=aktlocalswitches;
|
|
localmaxfpuregisters:=aktmaxfpuregisters;
|
|
{ parse the code ... }
|
|
code:=block(current_module.islibrary);
|
|
{ get a better entry point }
|
|
if assigned(code) then
|
|
entrypos:=code.fileinfo;
|
|
{ save exit info }
|
|
exitswitches:=aktlocalswitches;
|
|
exitpos:=last_endtoken_filepos;
|
|
{ save current filepos }
|
|
savepos:=aktfilepos;
|
|
|
|
{When we are called to compile the body of a unit, aktprocsym should
|
|
point to the unit initialization. If the unit has no initialization,
|
|
aktprocsym=nil. But in that case code=nil. hus we should check for
|
|
code=nil, when we use aktprocsym.}
|
|
|
|
{ set the start offset to the start of the temp area in the stack }
|
|
tg.setfirsttemp(procinfo^.firsttemp_offset);
|
|
|
|
{ ... and generate assembler }
|
|
{ but set the right switches for entry !! }
|
|
aktlocalswitches:=entryswitches;
|
|
oldaktmaxfpuregisters:=aktmaxfpuregisters;
|
|
aktmaxfpuregisters:=localmaxfpuregisters;
|
|
if assigned(code) then
|
|
begin
|
|
{ the procedure is now defined }
|
|
aktprocdef.forwarddef:=false;
|
|
|
|
{ only generate the code if no type errors are found, else
|
|
finish at least the type checking pass }
|
|
{$ifndef NOPASS2}
|
|
if (status.errorcount=0) then
|
|
begin
|
|
generatecode(code);
|
|
aktprocdef.code:=code;
|
|
{$ifdef testtemp}
|
|
if assigned(aktprocdef) and assigned(aktprocdef.localst) then
|
|
begin
|
|
stackframe:=align(tg.gettempsize+aktprocdef.localst.datasize,4);
|
|
end
|
|
else
|
|
begin
|
|
stackframe:=tg.gettempsize;
|
|
end;
|
|
if lexlevel = 1 then
|
|
WriteLn(stackframe);
|
|
{$else}
|
|
stackframe:=tg.gettempsize;
|
|
{ if lexlevel = 1 then
|
|
WriteLn(stackframe);}
|
|
{$endif}
|
|
{ first generate entry code with the correct position and switches }
|
|
aktfilepos:=entrypos;
|
|
aktlocalswitches:=entryswitches;
|
|
genentrycode(procinfo^.aktentrycode,make_global,stackframe,parasize,nostackframe,false);
|
|
|
|
{ FPC_POPADDRSTACK destroys all registers (JM) }
|
|
if (procinfo^.flags and (pi_needs_implicit_finally or pi_uses_exceptions)) <> 0 then
|
|
begin
|
|
rg.usedinproc := ALL_REGISTERS;
|
|
end;
|
|
|
|
{ now generate exit code with the correct position and switches }
|
|
aktfilepos:=exitpos;
|
|
aktlocalswitches:=exitswitches;
|
|
genexitcode(procinfo^.aktexitcode,parasize,nostackframe,false);
|
|
|
|
{ now all the registers used are known }
|
|
aktprocdef.usedregisters:=rg.usedinproc;
|
|
procinfo^.aktproccode.insertlist(procinfo^.aktentrycode);
|
|
procinfo^.aktproccode.concatlist(procinfo^.aktexitcode);
|
|
{$ifdef i386}
|
|
{$ifndef NoOpt}
|
|
if (cs_optimize in aktglobalswitches) and
|
|
{ do not optimize pure assembler procedures }
|
|
((procinfo^.flags and pi_is_assembler)=0) then
|
|
Optimize(procinfo^.aktproccode);
|
|
{$endif NoOpt}
|
|
{$endif i386}
|
|
{ save local data (casetable) also in the same file }
|
|
if assigned(procinfo^.aktlocaldata) and
|
|
(not procinfo^.aktlocaldata.empty) then
|
|
begin
|
|
procinfo^.aktproccode.concat(Tai_section.Create(sec_data));
|
|
procinfo^.aktproccode.concatlist(procinfo^.aktlocaldata);
|
|
procinfo^.aktproccode.concat(Tai_section.Create(sec_code));
|
|
end;
|
|
|
|
{ add the procedure to the codesegment }
|
|
if (cs_create_smart in aktmoduleswitches) then
|
|
codeSegment.concat(Tai_cut.Create);
|
|
codeSegment.concatlist(procinfo^.aktproccode);
|
|
end
|
|
else
|
|
do_resulttypepass(code);
|
|
{$else NOPASS2}
|
|
do_resulttypepass(code);
|
|
{$endif NOPASS2}
|
|
end;
|
|
|
|
{ ... remove symbol tables }
|
|
if lexlevel>=normal_function_level then
|
|
symtablestack:=symtablestack.next.next
|
|
else
|
|
symtablestack:=symtablestack.next;
|
|
|
|
{ ... check for unused symbols }
|
|
{ but only if there is no asm block }
|
|
if assigned(code) then
|
|
begin
|
|
if (Errorcount=0) then
|
|
begin
|
|
{ check if forwards are resolved }
|
|
tstoredsymtable(aktprocdef.localst).check_forwards;
|
|
{ check if all labels are used }
|
|
tstoredsymtable(aktprocdef.localst).checklabels;
|
|
{ remove cross unit overloads }
|
|
tstoredsymtable(aktprocdef.localst).unchain_overloaded;
|
|
end;
|
|
if (procinfo^.flags and pi_uses_asm)=0 then
|
|
begin
|
|
{ not for unit init, becuase the var can be used in finalize,
|
|
it will be done in proc_unit }
|
|
if not(aktprocdef.proctypeoption
|
|
in [potype_proginit,potype_unitinit,potype_unitfinalize]) then
|
|
tstoredsymtable(aktprocdef.localst).allsymbolsused;
|
|
tstoredsymtable(aktprocdef.parast).allsymbolsused;
|
|
end;
|
|
end;
|
|
|
|
{ the local symtables can be deleted, but the parast }
|
|
{ doesn't, (checking definitons when calling a }
|
|
{ function }
|
|
{ not for a inline procedure !! (PM) }
|
|
{ at lexlevel = 1 localst is the staticsymtable itself }
|
|
{ so no dispose here !! }
|
|
if assigned(code) and
|
|
not(cs_browser in aktmoduleswitches) and
|
|
(aktprocdef.proccalloption<>pocall_inline) then
|
|
begin
|
|
if lexlevel>=normal_function_level then
|
|
aktprocdef.localst.free;
|
|
aktprocdef.localst:=nil;
|
|
end;
|
|
|
|
{ all registers can be used again }
|
|
rg.resetusableregisters;
|
|
{ only now we can remove the temps }
|
|
tg.resettempgen;
|
|
|
|
{ remove code tree, if not inline procedure }
|
|
if assigned(code) and (aktprocdef.proccalloption<>pocall_inline) then
|
|
code.free;
|
|
|
|
{ remove class member symbol tables }
|
|
while symtablestack.symtabletype=objectsymtable do
|
|
symtablestack:=symtablestack.next;
|
|
|
|
aktmaxfpuregisters:=oldaktmaxfpuregisters;
|
|
|
|
{ restore filepos, the switches are already set }
|
|
aktfilepos:=savepos;
|
|
{ restore labels }
|
|
aktexitlabel:=oldexitlabel;
|
|
aktexit2label:=oldexit2label;
|
|
quickexitlabel:=oldquickexitlabel;
|
|
faillabel:=oldfaillabel;
|
|
|
|
{ reset to normal non static function }
|
|
if (lexlevel=normal_function_level) then
|
|
allow_only_static:=false;
|
|
{ previous lexlevel }
|
|
dec(lexlevel);
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
PROCEDURE/FUNCTION PARSING
|
|
****************************************************************************}
|
|
|
|
procedure checkvaluepara(p:tnamedindexitem;arg:pointer);
|
|
var
|
|
vs : tvarsym;
|
|
s : string;
|
|
begin
|
|
if tsym(p).typ<>varsym then
|
|
exit;
|
|
with tvarsym(p) do
|
|
begin
|
|
if copy(name,1,3)='val' then
|
|
begin
|
|
s:=Copy(name,4,255);
|
|
if not(po_assembler in aktprocdef.procoptions) then
|
|
begin
|
|
vs:=tvarsym.create(s,vartype);
|
|
vs.fileinfo:=fileinfo;
|
|
vs.varspez:=varspez;
|
|
aktprocdef.localst.insert(vs);
|
|
include(vs.varoptions,vo_is_local_copy);
|
|
vs.varstate:=vs_assigned;
|
|
localvarsym:=vs;
|
|
inc(refs); { the para was used to set the local copy ! }
|
|
{ warnings only on local copy ! }
|
|
varstate:=vs_used;
|
|
end
|
|
else
|
|
begin
|
|
aktprocdef.parast.rename(name,s);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure read_proc;
|
|
{
|
|
Parses the procedure directives, then parses the procedure body, then
|
|
generates the code for it
|
|
}
|
|
var
|
|
oldprocsym : tprocsym;
|
|
oldprocdef : tprocdef;
|
|
oldprocinfo : pprocinfo;
|
|
oldconstsymtable : tsymtable;
|
|
oldfilepos : tfileposinfo;
|
|
pdflags : word;
|
|
begin
|
|
{ save old state }
|
|
oldprocdef:=aktprocdef;
|
|
oldprocsym:=aktprocsym;
|
|
oldconstsymtable:=constsymtable;
|
|
oldprocinfo:=procinfo;
|
|
{ create a new procedure }
|
|
codegen_newprocedure;
|
|
with procinfo^ do
|
|
begin
|
|
parent:=oldprocinfo;
|
|
{ clear flags }
|
|
flags:=0;
|
|
{ standard frame pointer }
|
|
framepointer:=frame_pointer_reg;
|
|
{ is this a nested function of a method ? }
|
|
if assigned(oldprocinfo) then
|
|
_class:=oldprocinfo^._class;
|
|
end;
|
|
|
|
parse_proc_dec;
|
|
|
|
procinfo^.procdef:=aktprocdef;
|
|
|
|
{ set the default function options }
|
|
if parse_only then
|
|
begin
|
|
aktprocdef.forwarddef:=true;
|
|
{ set also the interface flag, for better error message when the
|
|
implementation doesn't much this header }
|
|
aktprocdef.interfacedef:=true;
|
|
pdflags:=pd_interface;
|
|
end
|
|
else
|
|
begin
|
|
pdflags:=pd_body;
|
|
if current_module.in_implementation then
|
|
pdflags:=pdflags or pd_implemen;
|
|
if (not current_module.is_unit) or (cs_create_smart in aktmoduleswitches) then
|
|
pdflags:=pdflags or pd_global;
|
|
procinfo^.exported:=false;
|
|
aktprocdef.forwarddef:=false;
|
|
end;
|
|
|
|
{ parse the directives that may follow }
|
|
inc(lexlevel);
|
|
parse_proc_directives(pdflags);
|
|
dec(lexlevel);
|
|
|
|
{ hint directives, these can be separated by semicolons here,
|
|
that need to be handled here with a loop (PFV) }
|
|
while try_consume_hintdirective(aktprocsym.symoptions) do
|
|
Consume(_SEMICOLON);
|
|
|
|
{ set aktfilepos to the beginning of the function declaration }
|
|
oldfilepos:=aktfilepos;
|
|
aktfilepos:=aktprocdef.fileinfo;
|
|
|
|
{ For varargs directive also cdecl and external must be defined }
|
|
if (po_varargs in aktprocdef.procoptions) then
|
|
begin
|
|
{ check first for external in the interface, if available there
|
|
then the cdecl must also be there since there is no implementation
|
|
available to contain it }
|
|
if parse_only then
|
|
begin
|
|
{ if external is available, then cdecl must also be available }
|
|
if (po_external in aktprocdef.procoptions) and
|
|
not(aktprocdef.proccalloption in [pocall_cdecl,pocall_cppdecl]) then
|
|
Message(parser_e_varargs_need_cdecl_and_external);
|
|
end
|
|
else
|
|
begin
|
|
{ both must be defined now }
|
|
if not(po_external in aktprocdef.procoptions) or
|
|
not(aktprocdef.proccalloption in [pocall_cdecl,pocall_cppdecl]) then
|
|
Message(parser_e_varargs_need_cdecl_and_external);
|
|
end;
|
|
end;
|
|
|
|
{ search for forward declarations }
|
|
if not proc_add_definition(aktprocsym,aktprocdef) then
|
|
begin
|
|
{ A method must be forward defined (in the object declaration) }
|
|
if assigned(procinfo^._class) and
|
|
(not assigned(oldprocinfo^._class)) then
|
|
begin
|
|
Message1(parser_e_header_dont_match_any_member,aktprocdef.fullprocname);
|
|
aktprocsym.write_parameter_lists(aktprocdef);
|
|
end
|
|
else
|
|
begin
|
|
{ Give a better error if there is a forward def in the interface and only
|
|
a single implementation }
|
|
if (not aktprocdef.forwarddef) and
|
|
assigned(aktprocsym.defs^.next) and
|
|
aktprocsym.defs^.def.forwarddef and
|
|
aktprocsym.defs^.def.interfacedef and
|
|
not(assigned(aktprocsym.defs^.next^.next)) then
|
|
begin
|
|
Message1(parser_e_header_dont_match_forward,aktprocdef.fullprocname);
|
|
aktprocsym.write_parameter_lists(aktprocdef);
|
|
end
|
|
else
|
|
begin
|
|
{ check the global flag, for delphi this is not
|
|
required }
|
|
if not(m_delphi in aktmodeswitches) and
|
|
((procinfo^.flags and pi_is_global)<>0) then
|
|
Message(parser_e_overloaded_must_be_all_global);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ update procinfo, because the aktprocdef can be
|
|
changed by check_identical_proc (PFV) }
|
|
procinfo^.procdef:=aktprocdef;
|
|
|
|
{$ifdef i386}
|
|
{ add implicit pushes for interrupt routines }
|
|
if (po_interrupt in aktprocdef.procoptions) then
|
|
begin
|
|
{ we push Flags and CS as long
|
|
to cope with the IRETD
|
|
and we save 6 register + 4 selectors }
|
|
inc(procinfo^.para_offset,8+6*4+4*2);
|
|
end;
|
|
{$endif i386}
|
|
|
|
{ pointer to the return value ? }
|
|
if paramanager.ret_in_param(aktprocdef.rettype.def) then
|
|
begin
|
|
procinfo^.return_offset:=procinfo^.para_offset;
|
|
inc(procinfo^.para_offset,pointer_size);
|
|
end;
|
|
{ allows to access the parameters of main functions in nested functions }
|
|
aktprocdef.parast.address_fixup:=procinfo^.para_offset;
|
|
|
|
{ when it is a value para and it needs a local copy then rename
|
|
the parameter and insert a copy in the localst. This is not done
|
|
for assembler procedures }
|
|
if (not parse_only) and (not aktprocdef.forwarddef) then
|
|
aktprocdef.parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}checkvaluepara,nil);
|
|
|
|
{ restore file pos }
|
|
aktfilepos:=oldfilepos;
|
|
|
|
{ compile procedure when a body is needed }
|
|
if (pdflags and pd_body)<>0 then
|
|
begin
|
|
Message1(parser_p_procedure_start,
|
|
aktprocdef.fullprocname);
|
|
aktprocdef.aliasnames.insert(aktprocdef.mangledname);
|
|
{ set _FAIL as keyword if constructor }
|
|
if (aktprocdef.proctypeoption=potype_constructor) then
|
|
tokeninfo^[_FAIL].keyword:=m_all;
|
|
if assigned(aktprocdef._class) then
|
|
tokeninfo^[_SELF].keyword:=m_all;
|
|
|
|
compile_proc_body(((pdflags and pd_global)<>0),assigned(oldprocinfo^._class));
|
|
|
|
{ reset _FAIL as normal }
|
|
if (aktprocdef.proctypeoption=potype_constructor) then
|
|
tokeninfo^[_FAIL].keyword:=m_none;
|
|
if assigned(aktprocdef._class) and (lexlevel=main_program_level) then
|
|
tokeninfo^[_SELF].keyword:=m_none;
|
|
consume(_SEMICOLON);
|
|
end;
|
|
{ close }
|
|
codegen_doneprocedure;
|
|
{ Restore old state }
|
|
constsymtable:=oldconstsymtable;
|
|
{$ifdef notused}
|
|
{ restore the interface order to maintain CRC values PM }
|
|
if assigned(prevdef) and assigned(aktprocdef.nextoverloaded) then
|
|
begin
|
|
stdef:=aktprocdef;
|
|
aktprocdef:=stdef.nextoverloaded;
|
|
stdef.nextoverloaded:=prevdef.nextoverloaded;
|
|
prevdef.nextoverloaded:=stdef;
|
|
end;
|
|
{$endif notused}
|
|
aktprocsym:=oldprocsym;
|
|
aktprocdef:=oldprocdef;
|
|
procinfo:=oldprocinfo;
|
|
otsym:=nil;
|
|
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);
|
|
|
|
procedure Not_supported_for_inline(t : ttoken);
|
|
begin
|
|
if assigned(aktprocsym) and
|
|
(aktprocdef.proccalloption=pocall_inline) then
|
|
Begin
|
|
Message1(parser_w_not_supported_for_inline,tokenstring(t));
|
|
Message(parser_w_inlining_disabled);
|
|
aktprocdef.proccalloption:=pocall_fpccall;
|
|
End;
|
|
end;
|
|
|
|
begin
|
|
repeat
|
|
case token of
|
|
_LABEL:
|
|
begin
|
|
Not_supported_for_inline(token);
|
|
label_dec;
|
|
end;
|
|
_CONST:
|
|
begin
|
|
Not_supported_for_inline(token);
|
|
const_dec;
|
|
end;
|
|
_TYPE:
|
|
begin
|
|
Not_supported_for_inline(token);
|
|
type_dec;
|
|
end;
|
|
_VAR:
|
|
var_dec;
|
|
_THREADVAR:
|
|
threadvar_dec;
|
|
_CONSTRUCTOR,_DESTRUCTOR,
|
|
_FUNCTION,_PROCEDURE,_OPERATOR,_CLASS:
|
|
begin
|
|
Not_supported_for_inline(token);
|
|
read_proc;
|
|
end;
|
|
_RESOURCESTRING:
|
|
resourcestring_dec;
|
|
_EXPORTS:
|
|
begin
|
|
Not_supported_for_inline(token);
|
|
{ here we should be at lexlevel 1, no ? PM }
|
|
if (lexlevel<>main_program_level) or
|
|
(current_module.is_unit) then
|
|
begin
|
|
Message(parser_e_syntax_error);
|
|
consume_all_until(_SEMICOLON);
|
|
end
|
|
else if islibrary or (target_info.target in [target_i386_WIN32,target_i386_wdosx,target_i386_Netware])
|
|
then // AD
|
|
read_exports;
|
|
end
|
|
else break;
|
|
end;
|
|
until false;
|
|
{ check for incomplete class definitions, this is only required
|
|
for fpc modes }
|
|
if (m_fpc in aktmodeswitches) then
|
|
symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class,nil);
|
|
end;
|
|
|
|
|
|
procedure read_interface_declarations;
|
|
begin
|
|
{Since the body is now parsed at lexlevel 1, and the declarations
|
|
must be parsed at the same lexlevel we increase the lexlevel.}
|
|
inc(lexlevel);
|
|
repeat
|
|
case token of
|
|
_CONST :
|
|
const_dec;
|
|
_TYPE :
|
|
type_dec;
|
|
_VAR :
|
|
var_dec;
|
|
_THREADVAR :
|
|
threadvar_dec;
|
|
_RESOURCESTRING:
|
|
resourcestring_dec;
|
|
_FUNCTION,
|
|
_PROCEDURE,
|
|
_OPERATOR :
|
|
read_proc;
|
|
else
|
|
break;
|
|
end;
|
|
until false;
|
|
dec(lexlevel);
|
|
{ check for incomplete class definitions, this is only required
|
|
for fpc modes }
|
|
if (m_fpc in aktmodeswitches) then
|
|
symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}check_forward_class,nil);
|
|
end;
|
|
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.57 2002-07-11 14:41:28 florian
|
|
* start of the new generic parameter handling
|
|
|
|
Revision 1.56 2002/07/07 09:52:32 florian
|
|
* powerpc target fixed, very simple units can be compiled
|
|
* some basic stuff for better callparanode handling, far from being finished
|
|
|
|
Revision 1.55 2002/07/04 20:43:01 florian
|
|
* first x86-64 patches
|
|
|
|
Revision 1.54 2002/07/01 18:46:25 peter
|
|
* internal linker
|
|
* reorganized aasm layer
|
|
|
|
Revision 1.53 2002/05/18 13:34:14 peter
|
|
* readded missing revisions
|
|
|
|
Revision 1.52 2002/05/16 19:46:44 carl
|
|
+ defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
|
|
+ try to fix temp allocation (still in ifdef)
|
|
+ generic constructor calls
|
|
+ start of tassembler / tmodulebase class cleanup
|
|
|
|
Revision 1.51 2002/05/14 19:34:49 peter
|
|
* removed old logs and updated copyright year
|
|
|
|
Revision 1.50 2002/05/12 16:53:09 peter
|
|
* moved entry and exitcode to ncgutil and cgobj
|
|
* foreach gets extra argument for passing local data to the
|
|
iterator function
|
|
* -CR checks also class typecasts at runtime by changing them
|
|
into as
|
|
* fixed compiler to cycle with the -CR option
|
|
* fixed stabs with elf writer, finally the global variables can
|
|
be watched
|
|
* removed a lot of routines from cga unit and replaced them by
|
|
calls to cgobj
|
|
* u32bit-s32bit updates for and,or,xor nodes. When one element is
|
|
u32bit then the other is typecasted also to u32bit without giving
|
|
a rangecheck warning/error.
|
|
* fixed pascal calling method with reversing also the high tree in
|
|
the parast, detected by tcalcst3 test
|
|
|
|
Revision 1.49 2002/04/20 21:32:24 carl
|
|
+ generic FPC_CHECKPOINTER
|
|
+ first parameter offset in stack now portable
|
|
* rename some constants
|
|
+ move some cpu stuff to other units
|
|
- remove unused constents
|
|
* fix stacksize for some targets
|
|
* fix generic size problems which depend now on EXTEND_SIZE constant
|
|
|
|
Revision 1.48 2002/04/19 15:46:02 peter
|
|
* mangledname rewrite, tprocdef.mangledname is now created dynamicly
|
|
in most cases and not written to the ppu
|
|
* add mangeledname_prefix() routine to generate the prefix of
|
|
manglednames depending on the current procedure, object and module
|
|
* removed static procprefix since the mangledname is now build only
|
|
on demand from tprocdef.mangledname
|
|
|
|
Revision 1.47 2002/04/15 19:01:28 carl
|
|
+ target_info.size_of_pointer -> pointer_Size
|
|
|
|
Revision 1.46 2002/04/04 18:45:19 carl
|
|
+ added wdosx support (patch from Pavel)
|
|
|
|
Revision 1.45 2002/03/31 20:26:36 jonas
|
|
+ a_loadfpu_* and a_loadmm_* methods in tcg
|
|
* register allocation is now handled by a class and is mostly processor
|
|
independent (+rgobj.pas and i386/rgcpu.pas)
|
|
* temp allocation is now handled by a class (+tgobj.pas, -i386\tgcpu.pas)
|
|
* some small improvements and fixes to the optimizer
|
|
* some register allocation fixes
|
|
* some fpuvaroffset fixes in the unary minus node
|
|
* push/popusedregisters is now called rg.save/restoreusedregisters and
|
|
(for i386) uses temps instead of push/pop's when using -Op3 (that code is
|
|
also better optimizable)
|
|
* fixed and optimized register saving/restoring for new/dispose nodes
|
|
* LOC_FPU locations now also require their "register" field to be set to
|
|
R_ST, not R_ST0 (the latter is used for LOC_CFPUREGISTER locations only)
|
|
- list field removed of the tnode class because it's not used currently
|
|
and can cause hard-to-find bugs
|
|
|
|
Revision 1.44 2002/01/19 15:37:24 peter
|
|
* commited the wrong file :(
|
|
|
|
Revision 1.43 2002/01/19 15:20:09 peter
|
|
* also check at the end of the implementation for incomplete classes
|
|
|
|
Revision 1.42 2002/01/19 15:12:34 peter
|
|
* check for unresolved forward classes in the interface
|
|
|
|
}
|