mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-31 21:29:41 +01:00
9adb202a92
+ Some initial work on a formaldef which also carries the typinfo of a parameter. git-svn-id: trunk@7639 -
1216 lines
43 KiB
ObjectPascal
1216 lines
43 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,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;
|
|
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;
|
|
casedeferror : boolean;
|
|
casenode : tcasenode;
|
|
begin
|
|
consume(_CASE);
|
|
caseexpr:=comp_expr(true);
|
|
{ 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;
|
|
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,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;
|
|
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;
|
|
if (p.nodetype=rangen) then
|
|
begin
|
|
{ type checking for case statements }
|
|
if 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);
|
|
testrange(casedef,hl2,false);
|
|
end;
|
|
end
|
|
else
|
|
CGMessage(parser_e_case_mismatch);
|
|
casenode.addlabel(blockid,hl1,hl2);
|
|
end
|
|
else
|
|
begin
|
|
{ type checking for case statements }
|
|
if not is_subequal(casedef, p.resultdef) then
|
|
CGMessage(parser_e_case_mismatch);
|
|
hl1:=get_ordinal_value(p);
|
|
if not casedeferror then
|
|
testrange(casedef,hl1,false);
|
|
casenode.addlabel(blockid,hl1,hl1);
|
|
end;
|
|
p.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);
|
|
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);
|
|
consume(_DO);
|
|
p_a:=statement;
|
|
result:=cwhilerepeatnode.create(p_e,p_a,true,false);
|
|
end;
|
|
|
|
|
|
function for_statement : tnode;
|
|
|
|
procedure check_range(hp:tnode);
|
|
begin
|
|
{$ifndef cpu64bit}
|
|
if hp.nodetype=ordconstn then
|
|
begin
|
|
if (tordconstnode(hp).value<int64(low(longint))) or
|
|
(tordconstnode(hp).value>high(longint)) then
|
|
begin
|
|
CGMessage(parser_e_range_check_error);
|
|
{ recover, prevent more warnings/errors }
|
|
tordconstnode(hp).value:=0;
|
|
end;
|
|
end;
|
|
{$endif cpu64bit}
|
|
end;
|
|
|
|
var
|
|
hp,
|
|
hloopvar,
|
|
hblock,
|
|
hto,hfrom : tnode;
|
|
backward : boolean;
|
|
loopvarsym : tabstractvarsym;
|
|
begin
|
|
{ parse loop header }
|
|
consume(_FOR);
|
|
|
|
hloopvar:=factor(false);
|
|
valid_for_loopvar(hloopvar,true);
|
|
|
|
{ Check loop variable }
|
|
loopvarsym:=nil;
|
|
|
|
{ variable must be an ordinal, int64 is not allowed for 32bit targets }
|
|
if not(is_ordinal(hloopvar.resultdef))
|
|
{$ifndef cpu64bit}
|
|
or is_64bitint(hloopvar.resultdef)
|
|
{$endif cpu64bit}
|
|
then
|
|
MessagePos(hloopvar.fileinfo,type_e_ordinal_expr_expected);
|
|
|
|
hp:=hloopvar;
|
|
while assigned(hp) and
|
|
(
|
|
{ record/object fields 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);
|
|
|
|
consume(_ASSIGNMENT);
|
|
|
|
hfrom:=comp_expr(true);
|
|
|
|
if try_to_consume(_DOWNTO) then
|
|
backward:=true
|
|
else
|
|
begin
|
|
consume(_TO);
|
|
backward:=false;
|
|
end;
|
|
|
|
hto:=comp_expr(true);
|
|
consume(_DO);
|
|
|
|
{ Check if the constants fit in the range }
|
|
check_range(hfrom);
|
|
check_range(hto);
|
|
|
|
{ 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);
|
|
set_varstate(hloopvar,vs_readwritten,[]);
|
|
|
|
{ ... 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 _with_statement : tnode;
|
|
|
|
var
|
|
p : tnode;
|
|
i : longint;
|
|
st : TSymtable;
|
|
newblock : tblocknode;
|
|
newstatement : tstatementnode;
|
|
calltempnode,
|
|
tempnode : ttempcreatenode;
|
|
valuenode,
|
|
hp,
|
|
refnode : tnode;
|
|
hdef : tdef;
|
|
hasimplicitderef : boolean;
|
|
withsymtablelist : TFPObjectList;
|
|
|
|
procedure pushobjchild(withdef,obj:tobjectdef);
|
|
begin
|
|
if not assigned(obj) then
|
|
exit;
|
|
pushobjchild(withdef,obj.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);
|
|
end;
|
|
|
|
|
|
begin
|
|
p:=comp_expr(true);
|
|
do_typecheckpass(p);
|
|
|
|
if (p.nodetype=vecn) and
|
|
(nf_memseg in p.flags) then
|
|
CGMessage(parser_e_no_with_for_variable_in_other_segments);
|
|
|
|
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])
|
|
) 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;
|
|
{ classes and interfaces have implicit dereferencing }
|
|
hasimplicitderef:=is_class_or_interface(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(aint),tt_persistent,true,p);
|
|
typecheckpass(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;
|
|
|
|
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 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 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
|
|
st:=twithsymtable.create(trecorddef(p.resultdef),trecorddef(p.resultdef).symtable.SymList,refnode);
|
|
symtablestack.push(st);
|
|
withsymtablelist.add(st);
|
|
end;
|
|
else
|
|
internalerror(200601271);
|
|
end;
|
|
|
|
if try_to_consume(_COMMA) then
|
|
p:=_with_statement()
|
|
else
|
|
begin
|
|
consume(_DO);
|
|
if token<>_SEMICOLON then
|
|
p:=statement
|
|
else
|
|
p:=cerrornode.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);
|
|
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 : tDef;
|
|
sym : tlocalvarsym;
|
|
old_block_type : tblock_type;
|
|
excepTSymtable : TSymtable;
|
|
objname,objrealname : TIDString;
|
|
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:=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) 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;
|
|
excepTSymtable:=tstt_excepTSymtable.create;
|
|
excepTSymtable.insert(sym);
|
|
symtablestack.push(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);
|
|
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) 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;
|
|
excepTSymtable:=nil;
|
|
end;
|
|
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;
|
|
aktexceptblock := oldaktexceptblock;
|
|
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
|
|
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(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 : tnode;
|
|
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
|
|
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 is only allowed to labels within the current scope }
|
|
if srsym.owner<>current_procinfo.procdef.localst then
|
|
CGMessage(parser_e_goto_outside_proc);
|
|
code:=cgotonode.create_sym(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:=call_fail_node;
|
|
end;
|
|
_ASM :
|
|
code:=_asm_statement;
|
|
_EOF :
|
|
Message(scan_f_end_of_file);
|
|
else
|
|
begin
|
|
p:=expr;
|
|
{ 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
|
|
p.free;
|
|
searchsym(s,srsym,srsymtable);
|
|
if assigned(srsym) and
|
|
(srsym.typ=labelsym) then
|
|
begin
|
|
if tlabelsym(srsym).defined then
|
|
Message(sym_e_label_already_defined);
|
|
tlabelsym(srsym).defined:=true;
|
|
p:=clabelnode.create(nil);
|
|
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,calln,ifn,assignn,breakn,inlinen,
|
|
continuen,labeln,blockn,exitn]) then
|
|
Message(parser_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(tcallnode(p).callnodeflags,cnf_return_value_used);
|
|
|
|
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;
|
|
locals : longint;
|
|
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;
|
|
|
|
{$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:=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
|
|
(current_procinfo.procdef.owner.symtabletype<>ObjectSymtable) 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 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.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.
|