{
$Id: pstatmnt.pas,v 1.124 2003/12/07 16:40:45 jonas Exp $
Copyright (c) 1998-2002 by Florian Klaempfl
Does the parsing of the statements
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 pstatmnt;
{$i fpcdefs.inc}
interface
uses
tokens,node;
function statement_block(starttoken : ttoken) : tnode;
{ reads an assembler block }
function assembler_block : tnode;
implementation
uses
{ common }
cutils,cclasses,
{ global }
globtype,globals,verbose,
systems,cpuinfo,
{ aasm }
cpubase,aasmbase,aasmtai,
{ symtable }
symconst,symbase,symtype,symdef,symsym,symtable,defutil,defcmp,
paramgr,symutil,
{ pass 1 }
pass_1,htypechk,
nutils,nbas,nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,
{ parser }
scanner,
pbase,pexpr,
{ codegen }
procinfo,cgbase,
{ assembler reader }
rabase
;
function statement : tnode;forward;
function if_statement : tnode;
var
ex,if_a,else_a : tnode;
begin
consume(_IF);
ex:=comp_expr(true);
consume(_THEN);
if token<>_ELSE then
if_a:=statement
else
if_a:=nil;
if try_to_consume(_ELSE) then
else_a:=statement
else
else_a:=nil;
if_statement:=genloopnode(ifn,ex,if_a,else_a,false);
end;
{ creates a block (list) of statements, til the next END token }
function statements_til_end : tnode;
var
first,last : tstatementnode;
begin
first:=nil;
while token<>_END do
begin
if first=nil then
begin
last:=cstatementnode.create(statement,nil);
first:=last;
end
else
begin
last.right:=cstatementnode.create(statement,nil);
last:=tstatementnode(last.right);
end;
if not try_to_consume(_SEMICOLON) then
break;
consume_emptystats;
end;
consume(_END);
statements_til_end:=cblocknode.create(first);
end;
function case_statement : tnode;
var
{ contains the label number of currently parsed case block }
aktcaselabel : tasmlabel;
firstlabel : boolean;
root : pcaserecord;
{ the typ of the case expression }
casedef : tdef;
procedure newcaselabel(l,h : TConstExprInt;first:boolean);
var
hcaselabel : pcaserecord;
procedure insertlabel(var p : pcaserecord);
begin
if p=nil then p:=hcaselabel
else
if (p^._low>hcaselabel^._low) and
(p^._low>hcaselabel^._high) then
if (hcaselabel^.statement = p^.statement) and
(p^._low = hcaselabel^._high + 1) then
begin
p^._low := hcaselabel^._low;
dispose(hcaselabel);
end
else
insertlabel(p^.less)
else
if (p^._high<hcaselabel^._low) and
(p^._high<hcaselabel^._high) then
if (hcaselabel^.statement = p^.statement) and
(p^._high+1 = hcaselabel^._low) then
begin
p^._high := hcaselabel^._high;
dispose(hcaselabel);
end
else
insertlabel(p^.greater)
else Message(parser_e_double_caselabel);
end;
begin
new(hcaselabel);
hcaselabel^.less:=nil;
hcaselabel^.greater:=nil;
hcaselabel^.statement:=aktcaselabel;
hcaselabel^.firstlabel:=first;
objectlibrary.getlabel(hcaselabel^._at);
hcaselabel^._low:=l;
hcaselabel^._high:=h;
insertlabel(root);
end;
var
code,caseexpr,p,instruc,elseblock : tnode;
hl1,hl2 : TConstExprInt;
casedeferror : boolean;
begin
consume(_CASE);
caseexpr:=comp_expr(true);
{ determines result type }
do_resulttypepass(caseexpr);
set_varstate(caseexpr,vs_used,true);
casedeferror:=false;
casedef:=caseexpr.resulttype.def;
if (not assigned(casedef)) or
not(is_ordinal(casedef)) then
begin
CGMessage(type_e_ordinal_expr_expected);
{ create a correct tree }
caseexpr.free;
caseexpr:=cordconstnode.create(0,u32bittype,false);
{ set error flag so no rangechecks are done }
casedeferror:=true;
end;
consume(_OF);
root:=nil;
instruc:=nil;
repeat
objectlibrary.getlabel(aktcaselabel);
firstlabel:=true;
{ maybe an instruction has more case labels }
repeat
p:=expr;
if is_widechar(casedef) then
begin
if (p.nodetype=rangen) then
begin
trangenode(p).left:=ctypeconvnode.create(trangenode(p).left,cwidechartype);
trangenode(p).right:=ctypeconvnode.create(trangenode(p).right,cwidechartype);
do_resulttypepass(trangenode(p).left);
do_resulttypepass(trangenode(p).right);
end
else
begin
p:=ctypeconvnode.create(p,cwidechartype);
do_resulttypepass(p);
end;
end;
hl1:=0;
hl2:=0;
if (p.nodetype=rangen) then
begin
{ type checking for case statements }
if is_subequal(casedef, trangenode(p).left.resulttype.def) and
is_subequal(casedef, trangenode(p).right.resulttype.def) then
begin
hl1:=get_ordinal_value(trangenode(p).left);
hl2:=get_ordinal_value(trangenode(p).right);
if hl1>hl2 then
CGMessage(parser_e_case_lower_less_than_upper_bound);
if not casedeferror then
begin
testrange(casedef,hl1,false);
testrange(casedef,hl2,false);
end;
end
else
CGMessage(parser_e_case_mismatch);
newcaselabel(hl1,hl2,firstlabel);
end
else
begin
{ type checking for case statements }
if not is_subequal(casedef, p.resulttype.def) then
CGMessage(parser_e_case_mismatch);
hl1:=get_ordinal_value(p);
if not casedeferror then
testrange(casedef,hl1,false);
newcaselabel(hl1,hl1,firstlabel);
end;
p.free;
if token=_COMMA then
consume(_COMMA)
else
break;
firstlabel:=false;
until false;
consume(_COLON);
{ handles instruction block }
p:=clabelnode.createcase(aktcaselabel,statement);
{ concats instruction }
instruc:=cstatementnode.create(p,instruc);
if not(token in [_ELSE,_OTHERWISE,_END]) then
consume(_SEMICOLON);
until (token in [_ELSE,_OTHERWISE,_END]);
if (token in [_ELSE,_OTHERWISE]) then
begin
if not try_to_consume(_ELSE) then
consume(_OTHERWISE);
elseblock:=statements_til_end;
end
else
begin
elseblock:=nil;
consume(_END);
end;
code:=ccasenode.create(caseexpr,instruc,root);
tcasenode(code).elseblock:=elseblock;
case_statement:=code;
end;
function repeat_statement : tnode;
var
first,last,p_e : tnode;
begin
consume(_REPEAT);
first:=nil;
while token<>_UNTIL do
begin
if first=nil then
begin
last:=cstatementnode.create(statement,nil);
first:=last;
end
else
begin
tstatementnode(last).right:=cstatementnode.create(statement,nil);
last:=tstatementnode(last).right;
end;
if not try_to_consume(_SEMICOLON) then
break;
consume_emptystats;
end;
consume(_UNTIL);
first:=cblocknode.create(first);
p_e:=comp_expr(true);
repeat_statement:=genloopnode(whilerepeatn,p_e,first,nil,true);
end;
function while_statement : tnode;
var
p_e,p_a : tnode;
begin
consume(_WHILE);
p_e:=comp_expr(true);
consume(_DO);
p_a:=statement;
while_statement:=genloopnode(whilerepeatn,p_e,p_a,nil,false);
end;
function for_statement : tnode;
var
p_e,tovalue,p_a : tnode;
backward : boolean;
begin
{ parse loop header }
consume(_FOR);
p_e:=expr;
if token=_DOWNTO then
begin
consume(_DOWNTO);
backward:=true;
end
else
begin
consume(_TO);
backward:=false;
end;
tovalue:=comp_expr(true);
consume(_DO);
{ ... now the instruction }
p_a:=statement;
for_statement:=genloopnode(forn,p_e,tovalue,p_a,backward);
end;
function _with_statement : tnode;
var
right,p : tnode;
i,levelcount : longint;
withsymtable,symtab : tsymtable;
obj : tobjectdef;
hp : tnode;
newblock : tblocknode;
newstatement : tstatementnode;
calltempp,
loadp : ttempcreatenode;
refp : tnode;
htype : ttype;
hasimplicitderef : boolean;
begin
p:=comp_expr(true);
do_resulttypepass(p);
set_varstate(p,vs_used,false);
right:=nil;
if (not codegenerror) and
(p.resulttype.def.deftype in [objectdef,recorddef]) then
begin
newblock:=nil;
{ ignore nodes that don't add instructions in the tree }
hp:=p;
while { equal type conversions }
(
(hp.nodetype=typeconvn) and
(ttypeconvnode(hp).convtype=tc_equal)
) or
{ constant array index }
(
(hp.nodetype=vecn) and
(tvecnode(hp).right.nodetype=ordconstn)
) do
hp:=tunarynode(hp).left;
if (hp.nodetype=loadn) and
(
(tloadnode(hp).symtable=current_procinfo.procdef.localst) or
(tloadnode(hp).symtable=current_procinfo.procdef.parast) or
(tloadnode(hp).symtable.symtabletype in [staticsymtable,globalsymtable])
) then
begin
{ simple load, we can reference direct }
loadp:=nil;
refp:=p;
end
else
begin
calltempp:=nil;
{ complex load, load in temp first }
newblock:=internalstatements(newstatement);
{ when right is a call then load it first in a temp }
if p.nodetype=calln then
begin
calltempp:=ctempcreatenode.create(p.resulttype,p.resulttype.def.size,tt_persistent);
addstatement(newstatement,calltempp);
addstatement(newstatement,cassignmentnode.create(
ctemprefnode.create(calltempp),
p));
p:=ctemprefnode.create(calltempp);
resulttypepass(p);
end;
{ classes and interfaces have implicit dereferencing }
hasimplicitderef:=is_class_or_interface(p.resulttype.def);
if hasimplicitderef then
htype:=p.resulttype
else
htype.setdef(tpointerdef.create(p.resulttype));
loadp:=ctempcreatenode.create(htype,POINTER_SIZE,tt_persistent);
resulttypepass(loadp);
if hasimplicitderef then
begin
hp:=p;
refp:=ctemprefnode.create(loadp);
end
else
begin
hp:=caddrnode.create(p);
refp:=cderefnode.create(ctemprefnode.create(loadp));
end;
addstatement(newstatement,loadp);
addstatement(newstatement,cassignmentnode.create(
ctemprefnode.create(loadp),
hp));
resulttypepass(refp);
end;
case p.resulttype.def.deftype of
objectdef :
begin
obj:=tobjectdef(p.resulttype.def);
withsymtable:=twithsymtable.Create(obj,obj.symtable.symsearch,refp);
{ include also all parent symtables }
levelcount:=1;
obj:=obj.childof;
symtab:=withsymtable;
while assigned(obj) do
begin
symtab.next:=twithsymtable.create(obj,obj.symtable.symsearch,refp.getcopy);
symtab:=symtab.next;
obj:=obj.childof;
inc(levelcount);
end;
symtab.next:=symtablestack;
symtablestack:=withsymtable;
end;
recorddef :
begin
symtab:=trecorddef(p.resulttype.def).symtable;
levelcount:=1;
withsymtable:=twithsymtable.create(trecorddef(p.resulttype.def),symtab.symsearch,refp);
withsymtable.next:=symtablestack;
symtablestack:=withsymtable;
end;
end;
if try_to_consume(_COMMA) then
right:=_with_statement{$ifdef FPCPROCVAR}(){$endif}
else
begin
consume(_DO);
if token<>_SEMICOLON then
right:=statement
else
right:=cerrornode.create;
end;
{ remove symtables from the stack }
for i:=1 to levelcount do
symtablestack:=symtablestack.next;
p:=cwithnode.create(right,twithsymtable(withsymtable),levelcount,refp);
{ Finalize complex withnode with destroy of temp }
if assigned(newblock) then
begin
addstatement(newstatement,p);
addstatement(newstatement,ctempdeletenode.create(loadp));
if assigned(calltempp) then
addstatement(newstatement,ctempdeletenode.create(calltempp));
p:=newblock;
end;
_with_statement:=p;
end
else
begin
p.free;
Message(parser_e_false_with_expr);
{ try to recover from error }
if try_to_consume(_COMMA) then
begin
hp:=_with_statement{$ifdef FPCPROCVAR}(){$endif};
if (hp=nil) then; { remove warning about unused }
end
else
begin
consume(_DO);
{ ignore all }
if token<>_SEMICOLON then
statement;
end;
_with_statement:=nil;
end;
end;
function with_statement : tnode;
begin
consume(_WITH);
with_statement:=_with_statement;
end;
function raise_statement : tnode;
var
p,pobj,paddr,pframe : tnode;
begin
pobj:=nil;
paddr:=nil;
pframe:=nil;
consume(_RAISE);
if not(token in endtokens) then
begin
{ object }
pobj:=comp_expr(true);
if try_to_consume(_AT) then
begin
paddr:=comp_expr(true);
if try_to_consume(_COMMA) then
pframe:=comp_expr(true);
end;
end
else
begin
if (block_type<>bt_except) then
Message(parser_e_no_reraise_possible);
end;
p:=craisenode.create(pobj,paddr,pframe);
raise_statement:=p;
end;
function try_statement : tnode;
var
p_try_block,p_finally_block,first,last,
p_default,p_specific,hp : tnode;
ot : ttype;
sym : tvarsym;
old_block_type : tblock_type;
exceptsymtable : tsymtable;
objname,objrealname : stringid;
srsym : tsym;
srsymtable : tsymtable;
oldaktexceptblock: integer;
begin
include(current_procinfo.flags,pi_uses_exceptions);
p_default:=nil;
p_specific:=nil;
{ read statements to try }
consume(_TRY);
first:=nil;
inc(exceptblockcounter);
oldaktexceptblock := aktexceptblock;
aktexceptblock := exceptblockcounter;
while (token<>_FINALLY) and (token<>_EXCEPT) do
begin
if first=nil then
begin
last:=cstatementnode.create(statement,nil);
first:=last;
end
else
begin
tstatementnode(last).right:=cstatementnode.create(statement,nil);
last:=tstatementnode(last).right;
end;
if not try_to_consume(_SEMICOLON) then
break;
consume_emptystats;
end;
p_try_block:=cblocknode.create(first);
if try_to_consume(_FINALLY) then
begin
inc(exceptblockcounter);
aktexceptblock := exceptblockcounter;
p_finally_block:=statements_til_end;
try_statement:=ctryfinallynode.create(p_try_block,p_finally_block);
end
else
begin
consume(_EXCEPT);
old_block_type:=block_type;
block_type:=bt_except;
inc(exceptblockcounter);
aktexceptblock := exceptblockcounter;
ot:=generrortype;
p_specific:=nil;
if (idtoken=_ON) then
{ catch specific exceptions }
begin
repeat
consume(_ID);
if token=_ID then
begin
objname:=pattern;
objrealname:=orgpattern;
{ can't use consume_sym here, because we need already
to check for the colon }
searchsym(objname,srsym,srsymtable);
consume(_ID);
{ is a explicit name for the exception given ? }
if try_to_consume(_COLON) then
begin
consume_sym(srsym,srsymtable);
if (srsym.typ=typesym) and
is_class(ttypesym(srsym).restype.def) then
begin
ot:=ttypesym(srsym).restype;
sym:=tvarsym.create(objrealname,vs_value,ot);
end
else
begin
sym:=tvarsym.create(objrealname,vs_value,generrortype);
if (srsym.typ=typesym) then
Message1(type_e_class_type_expected,ttypesym(srsym).restype.def.typename)
else
Message1(type_e_class_type_expected,ot.def.typename);
end;
exceptsymtable:=tstt_exceptsymtable.create;
exceptsymtable.insert(sym);
{ insert the exception symtable stack }
exceptsymtable.next:=symtablestack;
symtablestack:=exceptsymtable;
end
else
begin
{ check if type is valid, must be done here because
with "e: Exception" the e is not necessary }
if srsym=nil then
begin
identifier_not_found(objrealname);
srsym:=generrorsym;
end;
{ support unit.identifier }
if srsym.typ=unitsym then
begin
consume(_POINT);
srsym:=searchsymonlyin(tunitsym(srsym).unitsymtable,pattern);
if srsym=nil then
begin
identifier_not_found(orgpattern);
srsym:=generrorsym;
end;
consume(_ID);
end;
{ check if type is valid, must be done here because
with "e: Exception" the e is not necessary }
if (srsym.typ=typesym) and
is_class(ttypesym(srsym).restype.def) then
ot:=ttypesym(srsym).restype
else
begin
ot:=generrortype;
if (srsym.typ=typesym) then
Message1(type_e_class_type_expected,ttypesym(srsym).restype.def.typename)
else
Message1(type_e_class_type_expected,ot.def.typename);
end;
exceptsymtable:=nil;
end;
end
else
consume(_ID);
consume(_DO);
hp:=connode.create(nil,statement);
if ot.def.deftype=errordef then
begin
hp.free;
hp:=cerrornode.create;
end;
if p_specific=nil then
begin
last:=hp;
p_specific:=last;
end
else
begin
tonnode(last).left:=hp;
last:=tonnode(last).left;
end;
{ set the informations }
{ only if the creation of the onnode was succesful, it's possible }
{ that last and hp are errornodes (JM) }
if last.nodetype = onn then
begin
tonnode(last).excepttype:=tobjectdef(ot.def);
tonnode(last).exceptsymtable:=exceptsymtable;
end;
{ remove exception symtable }
if assigned(exceptsymtable) then
begin
symtablestack:=symtablestack.next;
if last.nodetype <> onn then
exceptsymtable.free;
end;
if not try_to_consume(_SEMICOLON) then
break;
consume_emptystats;
until (token in [_END,_ELSE]);
if try_to_consume(_ELSE) then
begin
{ catch the other exceptions }
p_default:=statements_til_end;
end
else
consume(_END);
end
else
begin
{ catch all exceptions }
p_default:=statements_til_end;
end;
block_type:=old_block_type;
try_statement:=ctryexceptnode.create(p_try_block,p_specific,p_default);
end;
aktexceptblock := oldaktexceptblock;
end;
function _asm_statement : tnode;
var
asmstat : tasmnode;
Marker : tai;
reg : tregister;
asmreader : tbaseasmreader;
begin
Inside_asm_statement:=true;
if aktasmmode=asmmode_direct then
begin
if not target_asm.allowdirect then
Message(parser_f_direct_assembler_not_allowed);
if (current_procinfo.procdef.proccalloption=pocall_inline) then
Begin
Message1(parser_w_not_supported_for_inline,'direct asm');
Message(parser_w_inlining_disabled);
current_procinfo.procdef.proccalloption:=pocall_default;
End;
end;
if assigned(asmmodeinfos[aktasmmode]) then
begin
asmreader:=asmmodeinfos[aktasmmode]^.casmreader.create;
asmstat:=casmnode.create(asmreader.assemble as taasmoutput);
asmreader.free;
end
else
Message(parser_f_assembler_reader_not_supported);
{ Read first the _ASM statement }
consume(_ASM);
{ END is read, got a list of changed registers? }
if try_to_consume(_LECKKLAMMER) then
begin
asmstat.used_regs_fpu:=[0..first_fpu_imreg-1];
if token<>_RECKKLAMMER then
begin
repeat
{ it's possible to specify the modified registers }
reg:=std_regnum_search(lower(pattern));
if reg<>NR_NO then
begin
if getregtype(reg)=R_INTREGISTER then
include(asmstat.used_regs_int,getsupreg(reg));
end
else
Message(asmr_e_invalid_register);
consume(_CSTRING);
if not try_to_consume(_COMMA) then
break;
until false;
end;
consume(_RECKKLAMMER);
end
else
begin
asmstat.used_regs_int:=paramanager.get_volatile_registers_int(current_procinfo.procdef.proccalloption);
asmstat.used_regs_fpu:=paramanager.get_volatile_registers_fpu(current_procinfo.procdef.proccalloption);
end;
{ mark the start and the end of the assembler block
this is needed for the optimizer }
If Assigned(AsmStat.p_asm) Then
Begin
Marker := Tai_Marker.Create(AsmBlockStart);
AsmStat.p_asm.Insert(Marker);
Marker := Tai_Marker.Create(AsmBlockEnd);
AsmStat.p_asm.Concat(Marker);
End;
Inside_asm_statement:=false;
_asm_statement:=asmstat;
end;
function statement : tnode;
var
p : tnode;
code : tnode;
filepos : tfileposinfo;
srsym : tsym;
srsymtable : tsymtable;
s : stringid;
begin
filepos:=akttokenpos;
case token of
_GOTO :
begin
if not(cs_support_goto in aktmoduleswitches)then
Message(sym_e_goto_and_label_not_supported);
consume(_GOTO);
if (token<>_INTCONST) and (token<>_ID) then
begin
Message(sym_e_label_not_found);
code:=cerrornode.create;
end
else
begin
if token=_ID then
consume_sym(srsym,srsymtable)
else
begin
searchsym(pattern,srsym,srsymtable);
if srsym=nil then
begin
identifier_not_found(pattern);
srsym:=generrorsym;
srsymtable:=nil;
end;
consume(token);
end;
if srsym.typ<>labelsym then
begin
Message(sym_e_id_is_no_label_id);
code:=cerrornode.create;
end
else
begin
code:=cgotonode.create(tlabelsym(srsym));
tgotonode(code).labsym:=tlabelsym(srsym);
{ set flag that this label is used }
tlabelsym(srsym).used:=true;
end;
end;
end;
_BEGIN :
code:=statement_block(_BEGIN);
_IF :
code:=if_statement;
_CASE :
code:=case_statement;
_REPEAT :
code:=repeat_statement;
_WHILE :
code:=while_statement;
_FOR :
code:=for_statement;
_WITH :
code:=with_statement;
_TRY :
code:=try_statement;
_RAISE :
code:=raise_statement;
{ semicolons,else until and end are ignored }
_SEMICOLON,
_ELSE,
_UNTIL,
_END:
code:=cnothingnode.create;
_FAIL :
begin
if (current_procinfo.procdef.proctypeoption<>potype_constructor) then
Message(parser_e_fail_only_in_constructor);
consume(_FAIL);
code:=call_fail_node;
end;
_ASM :
code:=_asm_statement;
_EOF :
Message(scan_f_end_of_file);
else
begin
p:=expr;
{ When a colon follows a intconst then transform it into a label }
if try_to_consume(_COLON) then
begin
s:=tostr(tordconstnode(p).value);
p.free;
searchsym(s,srsym,srsymtable);
if assigned(srsym) then
begin
if tlabelsym(srsym).defined then
Message(sym_e_label_already_defined);
tlabelsym(srsym).defined:=true;
p:=clabelnode.create(tlabelsym(srsym),nil);
end
else
begin
Message1(sym_e_label_used_and_not_defined,s);
p:=cnothingnode.create;
end;
end;
if p.nodetype=labeln then
begin
{ the pointer to the following instruction }
{ isn't a very clean way }
tlabelnode(p).left:=statement{$ifdef FPCPROCVAR}(){$endif};
{ be sure to have left also resulttypepass }
resulttypepass(tlabelnode(p).left);
end;
{ blockn support because a read/write is changed into a blocknode }
{ with a separate statement for each read/write operation (JM) }
{ the same is true for val() if the third parameter is not 32 bit }
if not(p.nodetype in [nothingn,calln,ifn,assignn,breakn,inlinen,
continuen,labeln,blockn,exitn]) then
Message(cg_e_illegal_expression);
{ Specify that we don't use the value returned by the call.
This is used for :
- dispose of temp stack space
- dispose on FPU stack }
if (p.nodetype=calln) then
exclude(p.flags,nf_return_value_used);
code:=p;
end;
end;
if assigned(code) then
code.set_tree_filepos(filepos);
statement:=code;
end;
function statement_block(starttoken : ttoken) : tnode;
var
first,last : tnode;
filepos : tfileposinfo;
begin
first:=nil;
filepos:=akttokenpos;
consume(starttoken);
while not(token in [_END,_FINALIZATION]) do
begin
if first=nil then
begin
last:=cstatementnode.create(statement,nil);
first:=last;
end
else
begin
tstatementnode(last).right:=cstatementnode.create(statement,nil);
last:=tstatementnode(last).right;
end;
if (token in [_END,_FINALIZATION]) then
break
else
begin
{ if no semicolon, then error and go on }
if token<>_SEMICOLON then
begin
consume(_SEMICOLON);
consume_all_until(_SEMICOLON);
end;
consume(_SEMICOLON);
end;
consume_emptystats;
end;
{ don't consume the finalization token, it is consumed when
reading the finalization block, but allow it only after
an initalization ! }
if (starttoken<>_INITIALIZATION) or (token<>_FINALIZATION) then
consume(_END);
last:=cblocknode.create(first);
last.set_tree_filepos(filepos);
statement_block:=last;
end;
function assembler_block : tnode;
var
p : tnode;
locals : longint;
begin
{ Rename the funcret so that recursive calls are possible }
if not is_void(current_procinfo.procdef.rettype.def) then
symtablestack.rename(current_procinfo.procdef.resultname,'$hiddenresult');
{ delphi uses register calling for assembler methods }
if (m_delphi in aktmodeswitches) and
(po_assembler in current_procinfo.procdef.procoptions) and
not(po_hascallingconvention in current_procinfo.procdef.procoptions) then
current_procinfo.procdef.proccalloption:=pocall_register;
{ force the asm statement }
if token<>_ASM then
consume(_ASM);
include(current_procinfo.flags,pi_is_assembler);
p:=_asm_statement;
{$ifndef sparc}
{$ifndef arm}
if (po_assembler in current_procinfo.procdef.procoptions) then
begin
{ set the framepointer to esp for assembler functions when the
following conditions are met:
- if the are no local variables and parameters (except the allocated result)
- no reference to the result variable (refcount<=1)
- result is not stored as parameter
- target processor has optional frame pointer save
(vm, i386, vm only currently)
}
locals:=0;
current_procinfo.procdef.localst.foreach_static({$ifdef FPCPROCVAR}@{$endif}count_locals,@locals);
current_procinfo.procdef.parast.foreach_static({$ifdef FPCPROCVAR}@{$endif}count_locals,@locals);
if (locals=0) and
(current_procinfo.procdef.owner.symtabletype<>objectsymtable) and
(not assigned(current_procinfo.procdef.funcretsym) or
(tvarsym(current_procinfo.procdef.funcretsym).refcount<=1)) and
not(paramanager.ret_in_param(current_procinfo.procdef.rettype.def,current_procinfo.procdef.proccalloption)) then
begin
{ Only need to set the framepointer, the locals will
be inserted with the correct reference in tcgasmnode.pass_2 }
current_procinfo.framepointer:=NR_STACK_POINTER_REG;
end;
end;
{$endif arm}
{$endif sparc}
{ Flag the result as assigned when it is returned in a
register.
}
if assigned(current_procinfo.procdef.funcretsym) and
(not paramanager.ret_in_param(current_procinfo.procdef.rettype.def,current_procinfo.procdef.proccalloption)) then
tvarsym(current_procinfo.procdef.funcretsym).varstate:=vs_assigned;
{ because the END is already read we need to get the
last_endtoken_filepos here (PFV) }
last_endtoken_filepos:=akttokenpos;
assembler_block:=p;
end;
end.
{
$Log: pstatmnt.pas,v $
Revision 1.124 2003/12/07 16:40:45 jonas
* moved count_locals from pstatmnt to symutils
* use count_locals in powerpc/cpupi to check whether we should set the
first temp offset (and as such generate a stackframe)
Revision 1.123 2003/12/03 17:39:04 florian
* fixed several arm calling conventions issues
* fixed reference reading in the assembler reader
* fixed a_loadaddr_ref_reg
Revision 1.122 2003/11/12 16:05:39 florian
* assembler readers OOPed
+ typed currency constants
+ typed 128 bit float constants if the CPU supports it
Revision 1.121 2003/11/11 21:10:12 peter
* remove temporary stdcall hack
Revision 1.120 2003/11/10 22:02:52 peter
* cross unit inlining fixed
Revision 1.119 2003/10/29 20:34:20 peter
* move check for unused object constructor result to blocknode
Revision 1.117 2003/10/29 15:40:20 peter
* support indexing and offset retrieval for locals
Revision 1.116 2003/10/17 14:38:32 peter
* 64k registers supported
* fixed some memory leaks
Revision 1.115 2003/10/10 17:48:13 peter
* old trgobj moved to x86/rgcpu and renamed to trgx86fpu
* tregisteralloctor renamed to trgobj
* removed rgobj from a lot of units
* moved location_* and reference_* to cgobj
* first things for mmx register allocation
Revision 1.114 2003/10/08 19:19:45 peter
* set_varstate cleanup
Revision 1.113 2003/10/07 20:06:37 peter
* set calling convention before assembler block is parsed
Revision 1.112 2003/10/02 21:15:59 peter
* delphi mode uses register calling by default for assembler
Revision 1.111 2003/10/01 20:34:49 peter
* procinfo unit contains tprocinfo
* cginfo renamed to cgbase
* moved cgmessage to verbose
* fixed ppc and sparc compiles
Revision 1.110 2003/09/23 17:56:05 peter
* locals and paras are allocated in the code generation
* tvarsym.localloc contains the location of para/local when
generating code for the current procedure
Revision 1.109 2003/09/16 16:17:01 peter
* varspez in calls to push_addr_param
Revision 1.108 2003/09/07 22:09:35 peter
* preparations for different default calling conventions
* various RA fixes
Revision 1.107 2003/09/03 15:55:01 peter
* NEWRA branch merged
Revision 1.106.2.3 2003/08/31 15:46:26 peter
* more updates for tregister
Revision 1.106.2.2 2003/08/29 17:28:59 peter
* next batch of updates
Revision 1.106.2.1 2003/08/28 18:35:08 peter
* tregister changed to cardinal
Revision 1.106 2003/07/08 21:24:59 peter
* sparc fixes
Revision 1.105 2003/06/17 16:34:44 jonas
* lots of newra fixes (need getfuncretparaloc implementation for i386)!
* renamed all_intregisters to paramanager.get_volatile_registers_int(pocall_default) and made it
processor dependent
Revision 1.104 2003/06/13 21:19:31 peter
* current_procdef removed, use current_procinfo.procdef instead
Revision 1.103 2003/06/09 18:27:14 peter
* load calln in temprefn in with statement
Revision 1.102 2003/05/23 22:33:48 florian
* fix some small flaws which prevent sparc linux system unit from compiling
* some reformatting done
Revision 1.101 2003/05/23 15:15:36 peter
* better error for undefined ordinal labels
Revision 1.100 2003/05/17 13:30:08 jonas
* changed tt_persistant to tt_persistent :)
* tempcreatenode now doesn't accept a boolean anymore for persistent
temps, but a ttemptype, so you can also create ansistring temps etc
Revision 1.99 2003/05/15 18:58:53 peter
* removed selfpointer_offset, vmtpointer_offset
* tvarsym.adjusted_address
* address in localsymtable is now in the real direction
* removed some obsolete globals
Revision 1.98 2003/05/13 19:14:41 peter
* failn removed
* inherited result code check moven to pexpr
Revision 1.97 2003/05/11 14:45:12 peter
* tloadnode does not support objectsymtable,withsymtable anymore
* withnode cleanup
* direct with rewritten to use temprefnode
Revision 1.96 2003/05/09 17:47:03 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.95 2003/04/30 22:15:59 florian
* some 64 bit adaptions in ncgadd
* x86-64 now uses ncgadd
* tparamanager.ret_in_acc doesn't return true anymore for a void-def
Revision 1.94 2003/04/27 11:21:34 peter
* aktprocdef renamed to current_procinfo.procdef
* procinfo renamed to current_procinfo
* procinfo will now be stored in current_module so it can be
cleaned up properly
* gen_main_procsym changed to create_main_proc and release_main_proc
to also generate a tprocinfo structure
* fixed unit implicit initfinal
Revision 1.93 2003/04/27 07:29:50 peter
* current_procinfo.procdef cleanup, current_procinfo.procdef is now always nil when parsing
a new procdef declaration
* aktprocsym removed
* lexlevel removed, use symtable.symtablelevel instead
* implicit init/final code uses the normal genentry/genexit
* funcret state checking updated for new funcret handling
Revision 1.92 2003/04/26 11:30:59 florian
* fixed the powerpc to work with the new function result handling
Revision 1.91 2003/04/25 20:59:34 peter
* removed funcretn,funcretsym, function result is now in varsym
and aliases for result and function name are added using absolutesym
* vs_hidden parameter for funcret passed in parameter
* vs_hidden fixes
* writenode changed to printnode and released from extdebug
* -vp option added to generate a tree.log with the nodetree
* nicer printnode for statements, callnode
Revision 1.90 2002/04/25 20:15:40 florian
* block nodes within expressions shouldn't release the used registers,
fixed using a flag till the new rg is ready
Revision 1.89 2003/04/25 08:25:26 daniel
* Ifdefs around a lot of calls to cleartempgen
* Fixed registers that are allocated but not freed in several nodes
* Tweak to register allocator to cause less spills
* 8-bit registers now interfere with esi,edi and ebp
Compiler can now compile rtl successfully when using new register
allocator
Revision 1.88 2003/03/28 19:16:57 peter
* generic constructor working for i386
* remove fixed self register
* esi added as address register for i386
Revision 1.87 2003/03/17 18:55:30 peter
* allow more tokens instead of only semicolon after inherited
Revision 1.86 2003/02/19 22:00:14 daniel
* Code generator converted to new register notation
- Horribily outdated todo.txt removed
Revision 1.85 2003/01/08 18:43:56 daniel
* Tregister changed into a record
Revision 1.84 2003/01/01 21:05:24 peter
* fixed assembler methods stackpointer optimization that was
broken after the previous change
Revision 1.83 2002/12/29 18:59:34 peter
* fixed parsing of declarations before asm statement
Revision 1.82 2002/12/27 18:18:56 peter
* check for else after empty raise statement
Revision 1.81 2002/11/27 02:37:14 peter
* case statement inlining added
* fixed inlining of write()
* switched statementnode left and right parts so the statements are
processed in the correct order when getcopy is used. This is
required for tempnodes
Revision 1.80 2002/11/25 17:43:22 peter
* splitted defbase in defutil,symutil,defcmp
* merged isconvertable and is_equal into compare_defs(_ext)
* made operator search faster by walking the list only once
Revision 1.79 2002/11/18 17:31:58 peter
* pass proccalloption to ret_in_xxx and push_xxx functions
Revision 1.78 2002/09/07 19:34:08 florian
+ tcg.direction is used now
Revision 1.77 2002/09/07 15:25:07 peter
* old logs removed and tabs fixed
Revision 1.76 2002/09/07 12:16:03 carl
* second part bug report 1996 fix, testrange in cordconstnode
only called if option is set (also make parsing a tiny faster)
Revision 1.75 2002/09/02 18:40:52 peter
* fixed parsing of register names with lowercase
Revision 1.74 2002/09/01 14:43:12 peter
* fixed direct assembler for i386
Revision 1.73 2002/08/25 19:25:20 peter
* sym.insert_in_data removed
* symtable.insertvardata/insertconstdata added
* removed insert_in_data call from symtable.insert, it needs to be
called separatly. This allows to deref the address calculation
* procedures now calculate the parast addresses after the procedure
directives are parsed. This fixes the cdecl parast problem
* push_addr_param has an extra argument that specifies if cdecl is used
or not
Revision 1.72 2002/08/17 09:23:40 florian
* first part of procinfo rewrite
Revision 1.71 2002/08/16 14:24:58 carl
* issameref() to test if two references are the same (then emit no opcodes)
+ ret_in_reg to replace ret_in_acc
(fix some register allocation bugs at the same time)
+ save_std_register now has an extra parameter which is the
usedinproc registers
Revision 1.70 2002/08/11 14:32:27 peter
* renamed current_library to objectlibrary
Revision 1.69 2002/08/11 13:24:12 peter
* saving of asmsymbols in ppu supported
* asmsymbollist global is removed and moved into a new class
tasmlibrarydata that will hold the info of a .a file which
corresponds with a single module. Added librarydata to tmodule
to keep the library info stored for the module. In the future the
objectfiles will also be stored to the tasmlibrarydata class
* all getlabel/newasmsymbol and friends are moved to the new class
Revision 1.68 2002/08/10 14:46:30 carl
+ moved target_cpu_string to cpuinfo
* renamed asmmode enum.
* assembler reader has now less ifdef's
* move from nppcmem.pas -> ncgmem.pas vec. node.
Revision 1.67 2002/08/09 19:11:44 carl
+ reading of used registers in assembler routines is now
cpu-independent
Revision 1.66 2002/08/06 20:55:22 florian
* first part of ppc calling conventions fix
Revision 1.65 2002/07/28 20:45:22 florian
+ added direct assembler reader for PowerPC
Revision 1.64 2002/07/20 11:57:56 florian
* types.pas renamed to defbase.pas because D6 contains a types
unit so this would conflicts if D6 programms are compiled
+ Willamette/SSE2 instructions to assembler added
Revision 1.63 2002/07/19 11:41:36 daniel
* State tracker work
* The whilen and repeatn are now completely unified into whilerepeatn. This
allows the state tracker to change while nodes automatically into
repeat nodes.
* Resulttypepass improvements to the notn. 'not not a' is optimized away and
'not(a>b)' is optimized into 'a<=b'.
* Resulttypepass improvements to the whilerepeatn. 'while not a' is optimized
by removing the notn and later switchting the true and falselabels. The
same is done with 'repeat until not a'.
Revision 1.62 2002/07/16 15:34:20 florian
* exit is now a syssym instead of a keyword
Revision 1.61 2002/07/11 14:41:28 florian
* start of the new generic parameter handling
Revision 1.60 2002/07/04 20:43:01 florian
* first x86-64 patches
Revision 1.59 2002/07/01 18:46:25 peter
* internal linker
* reorganized aasm layer
Revision 1.58 2002/05/18 13:34:13 peter
* readded missing revisions
Revision 1.57 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
}
syntax highlighted by Code2HTML, v. 0.9.1