mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-30 22:33:41 +02:00
0a3a62811b
o always create exceptvarsym entry for on-nodes (on all targets) to remove
some special cases when an unnamed exception was caught
o the JVM tryfinally node generates the finally code twice: once for the
case where no exception occurs, and once when it does occur. The reason
is that the JVM's static bytecode verification otherwise cannot prove
that we will only reraise the caught exception when we caught one in
the first place (the old "jsr" opcode to de-duplicate finally code
is no longer used in JDK 1.6 because it suffered from the same problem,
see Sun Java bug
http://webcache.googleusercontent.com/search?q=cache:ZJFtvxuyhfMJ:bugs.sun.com/bugdatabase/view_bug.do%3Fbug_id%3D6491544 )
git-svn-id: branches/jvmbackend@18387 -
1392 lines
52 KiB
ObjectPascal
1392 lines
52 KiB
ObjectPascal
{
|
|
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,constexp,
|
|
systems,
|
|
{ aasm }
|
|
cpubase,aasmbase,aasmtai,aasmdata,
|
|
{ symtable }
|
|
symconst,symbase,symtype,symdef,symsym,symtable,defutil,defcmp,
|
|
paramgr,symutil,
|
|
{ pass 1 }
|
|
pass_1,htypechk,
|
|
nutils,ngenutil,nbas,nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,
|
|
{ parser }
|
|
scanner,
|
|
pbase,pexpr,
|
|
{ codegen }
|
|
procinfo,cgbase,
|
|
{ assembler reader }
|
|
rabase,
|
|
{ wide- and unicodestrings}
|
|
widestr
|
|
;
|
|
|
|
|
|
function statement : tnode;forward;
|
|
|
|
|
|
function if_statement : tnode;
|
|
var
|
|
ex,if_a,else_a : tnode;
|
|
begin
|
|
consume(_IF);
|
|
ex:=comp_expr(true,false);
|
|
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;
|
|
result:=cifnode.create(ex,if_a,else_a);
|
|
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
|
|
casedef : tdef;
|
|
caseexpr,p : tnode;
|
|
blockid : longint;
|
|
hl1,hl2 : TConstExprInt;
|
|
sl1,sl2 : tstringconstnode;
|
|
casedeferror, caseofstring : boolean;
|
|
casenode : tcasenode;
|
|
begin
|
|
consume(_CASE);
|
|
caseexpr:=comp_expr(true,false);
|
|
{ determines result type }
|
|
do_typecheckpass(caseexpr);
|
|
{ variants must be accepted, but first they must be converted to integer }
|
|
if caseexpr.resultdef.typ=variantdef then
|
|
begin
|
|
caseexpr:=ctypeconvnode.create_internal(caseexpr,sinttype);
|
|
do_typecheckpass(caseexpr);
|
|
end;
|
|
set_varstate(caseexpr,vs_read,[vsf_must_be_valid]);
|
|
casedeferror:=false;
|
|
casedef:=caseexpr.resultdef;
|
|
{ case of string must be rejected in delphi-, }
|
|
{ tp7/bp7-, mac-compatibility modes. }
|
|
caseofstring :=
|
|
([m_delphi, m_mac, m_tp7] * current_settings.modeswitches = []) and
|
|
is_string(casedef);
|
|
|
|
if (not assigned(casedef)) or
|
|
( not(is_ordinal(casedef)) and (not caseofstring) ) then
|
|
begin
|
|
CGMessage(type_e_ordinal_or_string_expr_expected);
|
|
{ create a correct tree }
|
|
caseexpr.free;
|
|
caseexpr:=cordconstnode.create(0,u32inttype,false);
|
|
{ set error flag so no rangechecks are done }
|
|
casedeferror:=true;
|
|
end;
|
|
{ Create casenode }
|
|
casenode:=ccasenode.create(caseexpr);
|
|
consume(_OF);
|
|
{ Parse all case blocks }
|
|
blockid:=0;
|
|
repeat
|
|
{ maybe an instruction has more case labels }
|
|
repeat
|
|
p:=expr(true);
|
|
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_typecheckpass(trangenode(p).left);
|
|
do_typecheckpass(trangenode(p).right);
|
|
end
|
|
else
|
|
begin
|
|
p:=ctypeconvnode.create(p,cwidechartype);
|
|
do_typecheckpass(p);
|
|
end;
|
|
end;
|
|
hl1:=0;
|
|
hl2:=0;
|
|
sl1:=nil;
|
|
sl2:=nil;
|
|
if (p.nodetype=rangen) then
|
|
begin
|
|
{ type check for string case statements }
|
|
if caseofstring and
|
|
is_conststring_or_constcharnode(trangenode(p).left) and
|
|
is_conststring_or_constcharnode(trangenode(p).right) then
|
|
begin
|
|
{ we need stringconstnodes, even if expression contains single chars }
|
|
sl1 := get_string_value(trangenode(p).left, tstringdef(casedef));
|
|
sl2 := get_string_value(trangenode(p).right, tstringdef(casedef));
|
|
if sl1.fullcompare(sl2) > 0 then
|
|
CGMessage(parser_e_case_lower_less_than_upper_bound);
|
|
end
|
|
{ type checking for ordinal case statements }
|
|
else if (not caseofstring) and
|
|
is_subequal(casedef, trangenode(p).left.resultdef) and
|
|
is_subequal(casedef, trangenode(p).right.resultdef) 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,false);
|
|
testrange(casedef,hl2,false,false);
|
|
end;
|
|
end
|
|
else
|
|
CGMessage(parser_e_case_mismatch);
|
|
|
|
if caseofstring then
|
|
casenode.addlabel(blockid,sl1,sl2)
|
|
else
|
|
casenode.addlabel(blockid,hl1,hl2);
|
|
end
|
|
else
|
|
begin
|
|
{ type check for string case statements }
|
|
if (caseofstring and (not is_conststring_or_constcharnode(p))) or
|
|
{ type checking for ordinal case statements }
|
|
((not caseofstring) and (not is_subequal(casedef, p.resultdef))) then
|
|
CGMessage(parser_e_case_mismatch);
|
|
|
|
if caseofstring then
|
|
begin
|
|
sl1:=get_string_value(p, tstringdef(casedef));
|
|
casenode.addlabel(blockid,sl1,sl1);
|
|
end
|
|
else
|
|
begin
|
|
hl1:=get_ordinal_value(p);
|
|
if not casedeferror then
|
|
testrange(casedef,hl1,false,false);
|
|
casenode.addlabel(blockid,hl1,hl1);
|
|
end;
|
|
end;
|
|
p.free;
|
|
sl1.free;
|
|
sl2.free;
|
|
|
|
if token=_COMMA then
|
|
consume(_COMMA)
|
|
else
|
|
break;
|
|
until false;
|
|
consume(_COLON);
|
|
|
|
{ add instruction block }
|
|
casenode.addblock(blockid,statement);
|
|
|
|
{ next block }
|
|
inc(blockid);
|
|
|
|
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);
|
|
casenode.addelseblock(statements_til_end);
|
|
end
|
|
else
|
|
consume(_END);
|
|
|
|
result:=casenode;
|
|
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,false);
|
|
result:=cwhilerepeatnode.create(p_e,first,false,true);
|
|
end;
|
|
|
|
|
|
function while_statement : tnode;
|
|
|
|
var
|
|
p_e,p_a : tnode;
|
|
|
|
begin
|
|
consume(_WHILE);
|
|
p_e:=comp_expr(true,false);
|
|
consume(_DO);
|
|
p_a:=statement;
|
|
result:=cwhilerepeatnode.create(p_e,p_a,true,false);
|
|
end;
|
|
|
|
|
|
function for_statement : tnode;
|
|
|
|
procedure check_range(hp:tnode; fordef: tdef);
|
|
begin
|
|
if (hp.nodetype=ordconstn) and
|
|
(fordef.typ<>errordef) then
|
|
testrange(fordef,tordconstnode(hp).value,false,true);
|
|
end;
|
|
|
|
function for_loop_create(hloopvar: tnode): tnode;
|
|
var
|
|
hp,
|
|
hblock,
|
|
hto,hfrom : tnode;
|
|
backward : boolean;
|
|
loopvarsym : tabstractvarsym;
|
|
begin
|
|
{ Check loop variable }
|
|
loopvarsym:=nil;
|
|
|
|
{ variable must be an ordinal, int64 is not allowed for 32bit targets }
|
|
if not(is_ordinal(hloopvar.resultdef))
|
|
{$ifndef cpu64bitaddr}
|
|
or is_64bitint(hloopvar.resultdef)
|
|
{$endif not cpu64bitaddr}
|
|
then
|
|
MessagePos(hloopvar.fileinfo,type_e_ordinal_expr_expected);
|
|
|
|
hp:=hloopvar;
|
|
while assigned(hp) and
|
|
(
|
|
{ record/object fields and array elements are allowed }
|
|
{ in tp7 mode only }
|
|
(
|
|
(m_tp7 in current_settings.modeswitches) and
|
|
(
|
|
((hp.nodetype=subscriptn) and
|
|
((tsubscriptnode(hp).left.resultdef.typ=recorddef) or
|
|
is_object(tsubscriptnode(hp).left.resultdef))
|
|
) or
|
|
{ constant array index }
|
|
(
|
|
(hp.nodetype=vecn) and
|
|
is_constintnode(tvecnode(hp).right)
|
|
)
|
|
)
|
|
) or
|
|
{ equal typeconversions }
|
|
(
|
|
(hp.nodetype=typeconvn) and
|
|
(ttypeconvnode(hp).convtype=tc_equal)
|
|
)
|
|
) do
|
|
begin
|
|
{ Use the recordfield for loopvarsym }
|
|
if not assigned(loopvarsym) and
|
|
(hp.nodetype=subscriptn) then
|
|
loopvarsym:=tsubscriptnode(hp).vs;
|
|
hp:=tunarynode(hp).left;
|
|
end;
|
|
|
|
if assigned(hp) and
|
|
(hp.nodetype=loadn) then
|
|
begin
|
|
case tloadnode(hp).symtableentry.typ of
|
|
staticvarsym,
|
|
localvarsym,
|
|
paravarsym :
|
|
begin
|
|
{ we need a simple loadn:
|
|
1. The load must be in a global symtable or
|
|
in the same level as the para of the current proc.
|
|
2. value variables (no const,out or var)
|
|
3. No threadvar, readonly or typedconst
|
|
}
|
|
if (
|
|
(tloadnode(hp).symtable.symtablelevel=main_program_level) or
|
|
(tloadnode(hp).symtable.symtablelevel=current_procinfo.procdef.parast.symtablelevel)
|
|
) and
|
|
(tabstractvarsym(tloadnode(hp).symtableentry).varspez=vs_value) and
|
|
([vo_is_thread_var,vo_is_typed_const] * tabstractvarsym(tloadnode(hp).symtableentry).varoptions=[]) then
|
|
begin
|
|
{ Assigning for-loop variable is only allowed in tp7 and macpas }
|
|
if ([m_tp7,m_mac] * current_settings.modeswitches = []) then
|
|
begin
|
|
if not assigned(loopvarsym) then
|
|
loopvarsym:=tabstractvarsym(tloadnode(hp).symtableentry);
|
|
include(loopvarsym.varoptions,vo_is_loop_counter);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
{ Typed const is allowed in tp7 }
|
|
if not(m_tp7 in current_settings.modeswitches) or
|
|
not(vo_is_typed_const in tabstractvarsym(tloadnode(hp).symtableentry).varoptions) then
|
|
MessagePos(hp.fileinfo,type_e_illegal_count_var);
|
|
end;
|
|
end;
|
|
else
|
|
MessagePos(hp.fileinfo,type_e_illegal_count_var);
|
|
end;
|
|
end
|
|
else
|
|
MessagePos(hloopvar.fileinfo,type_e_illegal_count_var);
|
|
|
|
hfrom:=comp_expr(true,false);
|
|
|
|
if try_to_consume(_DOWNTO) then
|
|
backward:=true
|
|
else
|
|
begin
|
|
consume(_TO);
|
|
backward:=false;
|
|
end;
|
|
|
|
hto:=comp_expr(true,false);
|
|
consume(_DO);
|
|
|
|
{ Check if the constants fit in the range }
|
|
check_range(hfrom,hloopvar.resultdef);
|
|
check_range(hto,hloopvar.resultdef);
|
|
|
|
{ first set the varstate for from and to, so
|
|
uses of loopvar in those expressions will also
|
|
trigger a warning when it is not used yet. This
|
|
needs to be done before the instruction block is
|
|
parsed to have a valid hloopvar }
|
|
typecheckpass(hfrom);
|
|
set_varstate(hfrom,vs_read,[vsf_must_be_valid]);
|
|
typecheckpass(hto);
|
|
set_varstate(hto,vs_read,[vsf_must_be_valid]);
|
|
typecheckpass(hloopvar);
|
|
{ in two steps, because vs_readwritten may turn on vsf_must_be_valid }
|
|
{ for some subnodes }
|
|
set_varstate(hloopvar,vs_written,[]);
|
|
set_varstate(hloopvar,vs_read,[vsf_must_be_valid]);
|
|
|
|
{ ... now the instruction block }
|
|
hblock:=statement;
|
|
|
|
{ variable is not used for loop counter anymore }
|
|
if assigned(loopvarsym) then
|
|
exclude(loopvarsym.varoptions,vo_is_loop_counter);
|
|
|
|
result:=cfornode.create(hloopvar,hfrom,hto,hblock,backward);
|
|
end;
|
|
|
|
|
|
function for_in_loop_create(hloopvar: tnode): tnode;
|
|
var
|
|
expr: tnode;
|
|
begin
|
|
expr:=comp_expr(true,false);
|
|
|
|
consume(_DO);
|
|
|
|
set_varstate(hloopvar,vs_written,[]);
|
|
set_varstate(hloopvar,vs_read,[vsf_must_be_valid]);
|
|
|
|
result:=create_for_in_loop(hloopvar,statement,expr);
|
|
|
|
expr.free;
|
|
end;
|
|
|
|
|
|
var
|
|
hloopvar: tnode;
|
|
begin
|
|
{ parse loop header }
|
|
consume(_FOR);
|
|
|
|
hloopvar:=factor(false,false);
|
|
valid_for_loopvar(hloopvar,true);
|
|
|
|
if try_to_consume(_ASSIGNMENT) then
|
|
result:=for_loop_create(hloopvar)
|
|
else if try_to_consume(_IN) then
|
|
result:=for_in_loop_create(hloopvar)
|
|
else
|
|
consume(_ASSIGNMENT); // fail
|
|
end;
|
|
|
|
|
|
function _with_statement : tnode;
|
|
|
|
var
|
|
p : tnode;
|
|
i : longint;
|
|
st : TSymtable;
|
|
newblock : tblocknode;
|
|
newstatement : tstatementnode;
|
|
calltempnode,
|
|
tempnode : ttempcreatenode;
|
|
valuenode,
|
|
hp,
|
|
refnode : tnode;
|
|
hdef : tdef;
|
|
extendeddef : tabstractrecorddef;
|
|
helperdef : tobjectdef;
|
|
hasimplicitderef : boolean;
|
|
withsymtablelist : TFPObjectList;
|
|
|
|
procedure pushobjchild(withdef,obj:tobjectdef);
|
|
var
|
|
parenthelperdef : tobjectdef;
|
|
begin
|
|
if not assigned(obj) then
|
|
exit;
|
|
pushobjchild(withdef,obj.childof);
|
|
{ we need to look for helpers that were defined for the parent
|
|
class as well }
|
|
search_last_objectpascal_helper(obj,current_structdef,parenthelperdef);
|
|
{ push the symtables of the helper's parents in reverse order }
|
|
if assigned(parenthelperdef) then
|
|
pushobjchild(withdef,parenthelperdef.childof);
|
|
{ keep the original tobjectdef as owner, because that is used for
|
|
visibility of the symtable }
|
|
st:=twithsymtable.create(withdef,obj.symtable.SymList,refnode.getcopy);
|
|
symtablestack.push(st);
|
|
withsymtablelist.add(st);
|
|
{ push the symtable of the helper }
|
|
if assigned(parenthelperdef) then
|
|
begin
|
|
st:=twithsymtable.create(withdef,parenthelperdef.symtable.SymList,refnode.getcopy);
|
|
symtablestack.push(st);
|
|
withsymtablelist.add(st);
|
|
end;
|
|
end;
|
|
|
|
|
|
begin
|
|
p:=comp_expr(true,false);
|
|
do_typecheckpass(p);
|
|
|
|
if (p.nodetype=vecn) and
|
|
(nf_memseg in p.flags) then
|
|
CGMessage(parser_e_no_with_for_variable_in_other_segments);
|
|
|
|
{ "with procvar" can never mean anything, so always try
|
|
to call it in case it returns a record/object/... }
|
|
maybe_call_procvar(p,false);
|
|
|
|
if (p.resultdef.typ in [objectdef,recorddef,classrefdef]) then
|
|
begin
|
|
newblock:=nil;
|
|
valuenode:=nil;
|
|
tempnode:=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])
|
|
) and
|
|
{ MacPas objects are mapped to classes, and the MacPas compilers
|
|
interpret with-statements with MacPas objects the same way
|
|
as records (the object referenced by the with-statement
|
|
must remain constant)
|
|
}
|
|
not(is_class(hp.resultdef) and
|
|
(m_mac in current_settings.modeswitches)) then
|
|
begin
|
|
{ simple load, we can reference direct }
|
|
refnode:=p;
|
|
end
|
|
else
|
|
begin
|
|
calltempnode:=nil;
|
|
{ complex load, load in temp first }
|
|
newblock:=internalstatements(newstatement);
|
|
{ when we can't take the address of p, load it in a temp }
|
|
{ since we may need its address later on }
|
|
if not valid_for_addr(p,false) then
|
|
begin
|
|
calltempnode:=ctempcreatenode.create(p.resultdef,p.resultdef.size,tt_persistent,true);
|
|
addstatement(newstatement,calltempnode);
|
|
addstatement(newstatement,cassignmentnode.create(
|
|
ctemprefnode.create(calltempnode),
|
|
p));
|
|
p:=ctemprefnode.create(calltempnode);
|
|
typecheckpass(p);
|
|
end;
|
|
{ several object types have implicit dereferencing }
|
|
hasimplicitderef:=is_implicit_pointer_object_type(p.resultdef) or
|
|
(p.resultdef.typ = classrefdef);
|
|
if hasimplicitderef then
|
|
hdef:=p.resultdef
|
|
else
|
|
hdef:=tpointerdef.create(p.resultdef);
|
|
{ load address of the value in a temp }
|
|
tempnode:=ctempcreatenode.create_withnode(hdef,sizeof(pint),tt_persistent,true,p);
|
|
typecheckpass(tnode(tempnode));
|
|
valuenode:=p;
|
|
refnode:=ctemprefnode.create(tempnode);
|
|
fillchar(refnode.fileinfo,sizeof(tfileposinfo),0);
|
|
{ add address call for valuenode and deref for refnode if this
|
|
is not done implicitly }
|
|
if not hasimplicitderef then
|
|
begin
|
|
valuenode:=caddrnode.create_internal_nomark(valuenode);
|
|
refnode:=cderefnode.create(refnode);
|
|
fillchar(refnode.fileinfo,sizeof(tfileposinfo),0);
|
|
end;
|
|
addstatement(newstatement,tempnode);
|
|
addstatement(newstatement,cassignmentnode.create(
|
|
ctemprefnode.create(tempnode),
|
|
valuenode));
|
|
typecheckpass(refnode);
|
|
end;
|
|
|
|
{ do we have a helper for this type? }
|
|
if p.resultdef.typ=classrefdef then
|
|
extendeddef:=tobjectdef(tclassrefdef(p.resultdef).pointeddef)
|
|
else
|
|
extendeddef:=tabstractrecorddef(p.resultdef);
|
|
search_last_objectpascal_helper(extendeddef,current_structdef,helperdef);
|
|
{ Note: the symtable of the helper is pushed after the following
|
|
"case", the symtables of the helper's parents are passed in
|
|
the "case" branches }
|
|
|
|
withsymtablelist:=TFPObjectList.create(true);
|
|
case p.resultdef.typ of
|
|
objectdef :
|
|
begin
|
|
{ push symtables of all parents in reverse order }
|
|
pushobjchild(tobjectdef(p.resultdef),tobjectdef(p.resultdef).childof);
|
|
{ push symtables of all parents of the helper in reverse order }
|
|
if assigned(helperdef) then
|
|
pushobjchild(helperdef,helperdef.childof);
|
|
{ push object symtable }
|
|
st:=twithsymtable.Create(tobjectdef(p.resultdef),tobjectdef(p.resultdef).symtable.SymList,refnode);
|
|
symtablestack.push(st);
|
|
withsymtablelist.add(st);
|
|
end;
|
|
classrefdef :
|
|
begin
|
|
{ push symtables of all parents in reverse order }
|
|
pushobjchild(tobjectdef(tclassrefdef(p.resultdef).pointeddef),tobjectdef(tclassrefdef(p.resultdef).pointeddef).childof);
|
|
{ push symtables of all parents of the helper in reverse order }
|
|
if assigned(helperdef) then
|
|
pushobjchild(helperdef,helperdef.childof);
|
|
{ push object symtable }
|
|
st:=twithsymtable.Create(tobjectdef(tclassrefdef(p.resultdef).pointeddef),tobjectdef(tclassrefdef(p.resultdef).pointeddef).symtable.SymList,refnode);
|
|
symtablestack.push(st);
|
|
withsymtablelist.add(st);
|
|
end;
|
|
recorddef :
|
|
begin
|
|
{ push symtables of all parents of the helper in reverse order }
|
|
if assigned(helperdef) then
|
|
pushobjchild(helperdef,helperdef.childof);
|
|
{ push record symtable }
|
|
st:=twithsymtable.create(trecorddef(p.resultdef),trecorddef(p.resultdef).symtable.SymList,refnode);
|
|
symtablestack.push(st);
|
|
withsymtablelist.add(st);
|
|
end;
|
|
else
|
|
internalerror(200601271);
|
|
end;
|
|
|
|
{ push helper symtable }
|
|
if assigned(helperdef) then
|
|
begin
|
|
st:=twithsymtable.Create(helperdef,helperdef.symtable.SymList,refnode.getcopy);
|
|
symtablestack.push(st);
|
|
withsymtablelist.add(st);
|
|
end;
|
|
|
|
if try_to_consume(_COMMA) then
|
|
p:=_with_statement()
|
|
else
|
|
begin
|
|
consume(_DO);
|
|
if token<>_SEMICOLON then
|
|
p:=statement
|
|
else
|
|
p:=cnothingnode.create;
|
|
end;
|
|
|
|
{ remove symtables in reverse order from the stack }
|
|
for i:=withsymtablelist.count-1 downto 0 do
|
|
symtablestack.pop(TSymtable(withsymtablelist[i]));
|
|
withsymtablelist.free;
|
|
|
|
// p:=cwithnode.create(right,twithsymtable(withsymtable),levelcount,refnode);
|
|
|
|
{ Finalize complex withnode with destroy of temp }
|
|
if assigned(newblock) then
|
|
begin
|
|
addstatement(newstatement,p);
|
|
if assigned(tempnode) then
|
|
addstatement(newstatement,ctempdeletenode.create(tempnode));
|
|
if assigned(calltempnode) then
|
|
addstatement(newstatement,ctempdeletenode.create(calltempnode));
|
|
p:=newblock;
|
|
end;
|
|
result:=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();
|
|
if (hp=nil) then; { remove warning about unused }
|
|
end
|
|
else
|
|
begin
|
|
consume(_DO);
|
|
{ ignore all }
|
|
if token<>_SEMICOLON then
|
|
statement;
|
|
end;
|
|
result:=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,false);
|
|
if try_to_consume(_AT) then
|
|
begin
|
|
paddr:=comp_expr(true,false);
|
|
if try_to_consume(_COMMA) then
|
|
pframe:=comp_expr(true,false);
|
|
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 : tDef;
|
|
sym : tlocalvarsym;
|
|
old_block_type : tblock_type;
|
|
excepTSymtable : TSymtable;
|
|
objname,objrealname : TIDString;
|
|
srsym : tsym;
|
|
srsymtable : TSymtable;
|
|
oldcurrent_exceptblock: 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);
|
|
oldcurrent_exceptblock := current_exceptblock;
|
|
current_exceptblock := 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);
|
|
current_exceptblock := 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);
|
|
current_exceptblock := exceptblockcounter;
|
|
ot:=generrordef;
|
|
p_specific:=nil;
|
|
if (idtoken=_ON) then
|
|
{ catch specific exceptions }
|
|
begin
|
|
repeat
|
|
consume(_ON);
|
|
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).typedef) or
|
|
is_javaclass(ttypesym(srsym).typedef)) then
|
|
begin
|
|
ot:=ttypesym(srsym).typedef;
|
|
sym:=tlocalvarsym.create(objrealname,vs_value,ot,[]);
|
|
end
|
|
else
|
|
begin
|
|
sym:=tlocalvarsym.create(objrealname,vs_value,generrordef,[]);
|
|
if (srsym.typ=typesym) then
|
|
Message1(type_e_class_type_expected,ttypesym(srsym).typedef.typename)
|
|
else
|
|
Message1(type_e_class_type_expected,ot.typename);
|
|
end;
|
|
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);
|
|
searchsym_in_module(tunitsym(srsym).module,pattern,srsym,srsymtable);
|
|
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).typedef) or
|
|
is_javaclass(ttypesym(srsym).typedef)) then
|
|
ot:=ttypesym(srsym).typedef
|
|
else
|
|
begin
|
|
ot:=generrordef;
|
|
if (srsym.typ=typesym) then
|
|
Message1(type_e_class_type_expected,ttypesym(srsym).typedef.typename)
|
|
else
|
|
Message1(type_e_class_type_expected,ot.typename);
|
|
end;
|
|
{ create dummy symbol so we don't need a special
|
|
case in ncgflw, and so that we always know the
|
|
type }
|
|
sym:=tlocalvarsym.create('$exceptsym',vs_value,ot,[]);
|
|
end;
|
|
excepTSymtable:=tstt_excepTSymtable.create;
|
|
excepTSymtable.insert(sym);
|
|
symtablestack.push(excepTSymtable);
|
|
end
|
|
else
|
|
consume(_ID);
|
|
consume(_DO);
|
|
hp:=connode.create(nil,statement);
|
|
if ot.typ=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);
|
|
tonnode(last).excepTSymtable:=excepTSymtable;
|
|
end;
|
|
{ remove exception symtable }
|
|
if assigned(excepTSymtable) then
|
|
begin
|
|
symtablestack.pop(excepTSymtable);
|
|
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;
|
|
current_exceptblock := oldcurrent_exceptblock;
|
|
end;
|
|
|
|
|
|
function _asm_statement : tnode;
|
|
var
|
|
asmstat : tasmnode;
|
|
Marker : tai;
|
|
reg : tregister;
|
|
asmreader : tbaseasmreader;
|
|
begin
|
|
Inside_asm_statement:=true;
|
|
if assigned(asmmodeinfos[current_settings.asmmode]) then
|
|
begin
|
|
asmreader:=asmmodeinfos[current_settings.asmmode]^.casmreader.create;
|
|
asmstat:=casmnode.create(asmreader.assemble as TAsmList);
|
|
asmreader.free;
|
|
end
|
|
else
|
|
Message(parser_f_assembler_reader_not_supported);
|
|
|
|
{ Mark procedure that it has assembler blocks }
|
|
include(current_procinfo.flags,pi_has_assembler_block);
|
|
|
|
{ Read first the _ASM statement }
|
|
consume(_ASM);
|
|
|
|
{ END is read, got a list of changed registers? }
|
|
if try_to_consume(_LECKKLAMMER) then
|
|
begin
|
|
{$ifdef cpunofpu}
|
|
asmstat.used_regs_fpu:=[0..first_int_imreg-1];
|
|
{$else cpunofpu}
|
|
asmstat.used_regs_fpu:=[0..first_fpu_imreg-1];
|
|
{$endif cpunofpu}
|
|
if token<>_RECKKLAMMER then
|
|
begin
|
|
if po_assembler in current_procinfo.procdef.procoptions then
|
|
Message(parser_w_register_list_ignored);
|
|
repeat
|
|
{ it's possible to specify the modified registers }
|
|
reg:=std_regnum_search(lower(cstringpattern));
|
|
if reg<>NR_NO then
|
|
begin
|
|
if (getregtype(reg)=R_INTREGISTER) and not(po_assembler in current_procinfo.procdef.procoptions) 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(mark_AsmBlockStart);
|
|
AsmStat.p_asm.Insert(Marker);
|
|
Marker := Tai_Marker.Create(mark_AsmBlockEnd);
|
|
AsmStat.p_asm.Concat(Marker);
|
|
End;
|
|
Inside_asm_statement:=false;
|
|
_asm_statement:=asmstat;
|
|
end;
|
|
|
|
|
|
function statement : tnode;
|
|
var
|
|
p,
|
|
code : tnode;
|
|
filepos : tfileposinfo;
|
|
srsym : tsym;
|
|
srsymtable : TSymtable;
|
|
s : TIDString;
|
|
begin
|
|
filepos:=current_tokenpos;
|
|
case token of
|
|
_GOTO :
|
|
begin
|
|
if not(cs_support_goto in current_settings.moduleswitches) 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
|
|
if token<>_INTCONST then
|
|
internalerror(201008021);
|
|
|
|
{ strip leading 0's in iso mode }
|
|
if m_iso in current_settings.modeswitches then
|
|
while pattern[1]='0' do
|
|
delete(pattern,1,1);
|
|
|
|
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
|
|
{ goto outside the current scope? }
|
|
if srsym.owner<>current_procinfo.procdef.localst then
|
|
begin
|
|
{ allowed? }
|
|
if not(m_non_local_goto in current_settings.modeswitches) then
|
|
Message(parser_e_goto_outside_proc);
|
|
end;
|
|
code:=cgotonode.create(tlabelsym(srsym));
|
|
tgotonode(code).labelsym:=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:=cnodeutils.call_fail_node;
|
|
end;
|
|
_ASM :
|
|
code:=_asm_statement;
|
|
_EOF :
|
|
Message(scan_f_end_of_file);
|
|
else
|
|
begin
|
|
{ don't typecheck yet, because that will also simplify, which may
|
|
result in not detecting certain kinds of syntax errors --
|
|
see mantis #15594 }
|
|
p:=expr(false);
|
|
{ save the pattern here for latter usage, the label could be "000",
|
|
even if we read an expression, the pattern is still valid if it's really
|
|
a label (FK)
|
|
if you want to mess here, take care of
|
|
tests/webtbs/tw3546.pp
|
|
}
|
|
s:=pattern;
|
|
|
|
{ When a colon follows a intconst then transform it into a label }
|
|
if (p.nodetype=ordconstn) and
|
|
try_to_consume(_COLON) then
|
|
begin
|
|
{ in iso mode, 0003: is equal to 3: }
|
|
if m_iso in current_settings.modeswitches then
|
|
searchsym(tostr(tordconstnode(p).value),srsym,srsymtable)
|
|
else
|
|
searchsym(s,srsym,srsymtable);
|
|
p.free;
|
|
|
|
if assigned(srsym) and
|
|
(srsym.typ=labelsym) then
|
|
begin
|
|
if tlabelsym(srsym).defined then
|
|
Message(sym_e_label_already_defined);
|
|
if symtablestack.top.symtablelevel<>srsymtable.symtablelevel then
|
|
begin
|
|
tlabelsym(srsym).nonlocal:=true;
|
|
exclude(current_procinfo.procdef.procoptions,po_inline);
|
|
end;
|
|
if tlabelsym(srsym).nonlocal and
|
|
(current_procinfo.procdef.proctypeoption in [potype_unitinit,potype_unitfinalize]) then
|
|
Message(sym_e_interprocgoto_into_init_final_code_not_allowed);
|
|
|
|
tlabelsym(srsym).defined:=true;
|
|
p:=clabelnode.create(nil,tlabelsym(srsym));
|
|
tlabelsym(srsym).code:=p;
|
|
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 }
|
|
if token in endtokens then
|
|
tlabelnode(p).left:=cnothingnode.create
|
|
else
|
|
tlabelnode(p).left:=statement();
|
|
{ be sure to have left also typecheckpass }
|
|
typecheckpass(tlabelnode(p).left);
|
|
end
|
|
else
|
|
|
|
{ change a load of a procvar to a call. this is also
|
|
supported in fpc mode }
|
|
if p.nodetype in [vecn,derefn,typeconvn,subscriptn,loadn] then
|
|
maybe_call_procvar(p,false);
|
|
|
|
{ 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,errorn,calln,ifn,assignn,breakn,inlinen,
|
|
continuen,labeln,blockn,exitn]) or
|
|
((p.nodetype=inlinen) and
|
|
not is_void(p.resultdef)) or
|
|
((p.nodetype=calln) and
|
|
(assigned(tcallnode(p).procdefinition)) and
|
|
(tcallnode(p).procdefinition.proctypeoption=potype_operator)) then
|
|
Message(parser_e_illegal_expression);
|
|
|
|
if not assigned(p.resultdef) then
|
|
do_typecheckpass(p);
|
|
|
|
{ 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
|
|
- extended syntax checking }
|
|
if (p.nodetype=calln) then
|
|
begin
|
|
exclude(tcallnode(p).callnodeflags,cnf_return_value_used);
|
|
|
|
{ in $x- state, the function result must not be ignored }
|
|
if not(cs_extsyntax in current_settings.moduleswitches) and
|
|
not(is_void(p.resultdef)) and
|
|
{ can be nil in case there was an error in the expression }
|
|
assigned(tcallnode(p).procdefinition) and
|
|
not((tcallnode(p).procdefinition.proctypeoption=potype_constructor) and
|
|
is_object(tprocdef(tcallnode(p).procdefinition).struct)) then
|
|
Message(parser_e_illegal_expression);
|
|
end;
|
|
code:=p;
|
|
end;
|
|
end;
|
|
if assigned(code) then
|
|
begin
|
|
typecheckpass(code);
|
|
code.fileinfo:=filepos;
|
|
end;
|
|
statement:=code;
|
|
end;
|
|
|
|
|
|
function statement_block(starttoken : ttoken) : tnode;
|
|
|
|
var
|
|
first,last : tnode;
|
|
filepos : tfileposinfo;
|
|
|
|
begin
|
|
first:=nil;
|
|
filepos:=current_tokenpos;
|
|
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.fileinfo:=filepos;
|
|
statement_block:=last;
|
|
end;
|
|
|
|
|
|
function assembler_block : tnode;
|
|
var
|
|
p : tnode;
|
|
{$ifndef arm}
|
|
locals : longint;
|
|
{$endif arm}
|
|
srsym : tsym;
|
|
begin
|
|
{ Rename the funcret so that recursive calls are possible }
|
|
if not is_void(current_procinfo.procdef.returndef) then
|
|
begin
|
|
srsym:=TSym(current_procinfo.procdef.localst.Find(current_procinfo.procdef.procsym.name));
|
|
if assigned(srsym) then
|
|
srsym.realname:='$hiddenresult';
|
|
end;
|
|
|
|
{ delphi uses register calling for assembler methods }
|
|
if (m_delphi in current_settings.modeswitches) 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;
|
|
|
|
{$if not(defined(sparc)) and not(defined(arm)) and not(defined(avr))}
|
|
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:=tabstractlocalsymtable(current_procinfo.procdef.parast).count_locals;
|
|
if (current_procinfo.procdef.localst.symtabletype=localsymtable) then
|
|
inc(locals,tabstractlocalsymtable(current_procinfo.procdef.localst).count_locals);
|
|
if (locals=0) and
|
|
not (current_procinfo.procdef.owner.symtabletype in [ObjectSymtable,recordsymtable]) and
|
|
(not assigned(current_procinfo.procdef.funcretsym) or
|
|
(tabstractvarsym(current_procinfo.procdef.funcretsym).refs<=1)) and
|
|
not(paramanager.ret_in_param(current_procinfo.procdef.returndef,current_procinfo.procdef.proccalloption)) then
|
|
begin
|
|
{ Only need to set the framepointer, the locals will
|
|
be inserted with the correct reference in tcgasmnode.pass_generate_code }
|
|
current_procinfo.framepointer:=NR_STACK_POINTER_REG;
|
|
end;
|
|
end;
|
|
{$endif not(defined(sparc)) and not(defined(arm)) and not(defined(avr))}
|
|
|
|
{ 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.returndef,current_procinfo.procdef.proccalloption)) then
|
|
tabstractvarsym(current_procinfo.procdef.funcretsym).varstate:=vs_initialised;
|
|
|
|
{ because the END is already read we need to get the
|
|
last_endtoken_filepos here (PFV) }
|
|
last_endtoken_filepos:=current_tokenpos;
|
|
|
|
assembler_block:=p;
|
|
end;
|
|
|
|
end.
|