mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-17 09:59:41 +02:00
1292 lines
44 KiB
ObjectPascal
1292 lines
44 KiB
ObjectPascal
{
|
|
$Id$
|
|
Copyright (c) 1998-2000 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 defines.inc}
|
|
|
|
interface
|
|
uses
|
|
tokens,node;
|
|
|
|
|
|
function statement_block(starttoken : ttoken) : tnode;
|
|
|
|
{ reads an assembler block }
|
|
function assembler_block : tnode;
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
{ common }
|
|
cutils,cobjects,
|
|
{ global }
|
|
globtype,globals,verbose,
|
|
systems,cpuinfo,
|
|
{ aasm }
|
|
cpubase,aasm,
|
|
{ symtable }
|
|
symconst,symtable,types,
|
|
ppu,fmodule,
|
|
{ pass 1 }
|
|
pass_1,htypechk,
|
|
nbas,nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,
|
|
{ parser }
|
|
scanner,
|
|
pbase,pexpr,
|
|
{$ifdef i386}
|
|
{$ifndef NoRa386Int}
|
|
ra386int,
|
|
{$endif NoRa386Int}
|
|
{$ifndef NoRa386Att}
|
|
ra386att,
|
|
{$endif NoRa386Att}
|
|
{$ifndef NoRa386Dir}
|
|
ra386dir,
|
|
{$endif NoRa386Dir}
|
|
{$endif i386}
|
|
{$ifdef m68k}
|
|
{$ifndef NoRa68kMot}
|
|
ra68kmot,
|
|
{$endif NoRa68kMot}
|
|
{$endif m68k}
|
|
{ codegen }
|
|
{$ifdef newcg}
|
|
cgbase
|
|
{$else newcg}
|
|
hcodegen
|
|
{$ifdef i386}
|
|
,tgeni386
|
|
{$endif i386}
|
|
{$ifdef m68k}
|
|
,tgen68k
|
|
{$endif m68k}
|
|
{$endif newcg}
|
|
;
|
|
|
|
|
|
const
|
|
statement_level : longint = 0;
|
|
|
|
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(nil,statement);
|
|
first:=last;
|
|
end
|
|
else
|
|
begin
|
|
last.left:=cstatementnode.create(nil,statement);
|
|
last:=tstatementnode(last.left);
|
|
end;
|
|
if not try_to_consume(_SEMICOLON) then
|
|
break;
|
|
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 : pasmlabel;
|
|
firstlabel : boolean;
|
|
root : pcaserecord;
|
|
|
|
{ the typ of the case expression }
|
|
casedef : pdef;
|
|
|
|
procedure newcaselabel(l,h : longint;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;
|
|
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 }
|
|
cleartempgen;
|
|
do_firstpass(caseexpr);
|
|
casedeferror:=false;
|
|
casedef:=caseexpr.resulttype;
|
|
if (not assigned(casedef)) or
|
|
not(is_ordinal(casedef)) then
|
|
begin
|
|
CGMessage(type_e_ordinal_expr_expected);
|
|
{ create a correct tree }
|
|
caseexpr.free;
|
|
caseexpr:=genordinalconstnode(0,u32bitdef);
|
|
{ set error flag so no rangechecks are done }
|
|
casedeferror:=true;
|
|
end;
|
|
|
|
consume(_OF);
|
|
inc(statement_level);
|
|
root:=nil;
|
|
instruc:=nil;
|
|
repeat
|
|
getlabel(aktcaselabel);
|
|
firstlabel:=true;
|
|
|
|
{ may be an instruction has more case labels }
|
|
repeat
|
|
p:=expr;
|
|
cleartempgen;
|
|
do_firstpass(p);
|
|
hl1:=0;
|
|
hl2:=0;
|
|
if (p.nodetype=rangen) then
|
|
begin
|
|
{ type checking for case statements }
|
|
if is_subequal(casedef, trangenode(p).left.resulttype) and
|
|
is_subequal(casedef, trangenode(p).right.resulttype) 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);
|
|
testrange(casedef,hl2);
|
|
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) then
|
|
CGMessage(parser_e_case_mismatch);
|
|
hl1:=get_ordinal_value(p);
|
|
if not casedeferror then
|
|
testrange(casedef,hl1);
|
|
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.create(aktcaselabel,statement);
|
|
|
|
{ concats instruction }
|
|
instruc:=cstatementnode.create(instruc,p);
|
|
|
|
if not((token=_ELSE) or (token=_OTHERWISE) or (token=_END)) then
|
|
consume(_SEMICOLON);
|
|
until (token=_ELSE) or (token=_OTHERWISE) or (token=_END);
|
|
|
|
if (token=_ELSE) or (token=_OTHERWISE) then
|
|
begin
|
|
if not try_to_consume(_ELSE) then
|
|
consume(_OTHERWISE);
|
|
elseblock:=statements_til_end;
|
|
end
|
|
else
|
|
begin
|
|
elseblock:=nil;
|
|
consume(_END);
|
|
end;
|
|
dec(statement_level);
|
|
|
|
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;
|
|
inc(statement_level);
|
|
|
|
while token<>_UNTIL do
|
|
begin
|
|
if first=nil then
|
|
begin
|
|
last:=cstatementnode.create(nil,statement);
|
|
first:=last;
|
|
end
|
|
else
|
|
begin
|
|
tstatementnode(last).left:=cstatementnode.create(nil,statement);
|
|
last:=tstatementnode(last).left;
|
|
end;
|
|
if not try_to_consume(_SEMICOLON) then
|
|
break;
|
|
emptystats;
|
|
end;
|
|
consume(_UNTIL);
|
|
dec(statement_level);
|
|
|
|
first:=cblocknode.create(first);
|
|
p_e:=comp_expr(true);
|
|
repeat_statement:=genloopnode(repeatn,p_e,first,nil,false);
|
|
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(whilen,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 : psymtable;
|
|
obj : pobjectdef;
|
|
hp : tnode;
|
|
begin
|
|
p:=comp_expr(true);
|
|
do_firstpass(p);
|
|
set_varstate(p,false);
|
|
right:=nil;
|
|
if (not codegenerror) and
|
|
(p.resulttype^.deftype in [objectdef,recorddef]) then
|
|
begin
|
|
case p.resulttype^.deftype of
|
|
objectdef : begin
|
|
obj:=pobjectdef(p.resulttype);
|
|
withsymtable:=new(pwithsymtable,init);
|
|
withsymtable^.symsearch:=obj^.symtable^.symsearch;
|
|
withsymtable^.defowner:=obj;
|
|
symtab:=withsymtable;
|
|
if (p.nodetype=loadn) and
|
|
(tloadnode(p).symtable=aktprocsym^.definition^.localst) then
|
|
pwithsymtable(symtab)^.direct_with:=true;
|
|
{symtab^.withnode:=p; not yet allocated !! }
|
|
pwithsymtable(symtab)^.withrefnode:=p;
|
|
levelcount:=1;
|
|
obj:=obj^.childof;
|
|
while assigned(obj) do
|
|
begin
|
|
symtab^.next:=new(pwithsymtable,init);
|
|
symtab:=symtab^.next;
|
|
symtab^.symsearch:=obj^.symtable^.symsearch;
|
|
if (p.nodetype=loadn) and
|
|
(tloadnode(p).symtable=aktprocsym^.definition^.localst) then
|
|
pwithsymtable(symtab)^.direct_with:=true;
|
|
{symtab^.withnode:=p; not yet allocated !! }
|
|
pwithsymtable(symtab)^.withrefnode:=p;
|
|
symtab^.defowner:=obj;
|
|
obj:=obj^.childof;
|
|
inc(levelcount);
|
|
end;
|
|
symtab^.next:=symtablestack;
|
|
symtablestack:=withsymtable;
|
|
end;
|
|
recorddef : begin
|
|
symtab:=precorddef(p.resulttype)^.symtable;
|
|
levelcount:=1;
|
|
withsymtable:=new(pwithsymtable,init);
|
|
withsymtable^.symsearch:=symtab^.symsearch;
|
|
withsymtable^.next:=symtablestack;
|
|
if (p.nodetype=loadn) and
|
|
(tloadnode(p).symtable=aktprocsym^.definition^.localst) then
|
|
pwithsymtable(withsymtable)^.direct_with:=true;
|
|
{symtab^.withnode:=p; not yet allocated !! }
|
|
pwithsymtable(withsymtable)^.withrefnode:=p;
|
|
withsymtable^.defowner:=precorddef(p.resulttype);
|
|
symtablestack:=withsymtable;
|
|
end;
|
|
end;
|
|
if token=_COMMA then
|
|
begin
|
|
consume(_COMMA);
|
|
right:=_with_statement{$ifdef FPCPROCVAR}(){$endif};
|
|
end
|
|
else
|
|
begin
|
|
consume(_DO);
|
|
if token<>_SEMICOLON then
|
|
right:=statement
|
|
else
|
|
right:=nil;
|
|
end;
|
|
for i:=1 to levelcount do
|
|
symtablestack:=symtablestack^.next;
|
|
_with_statement:=genwithnode(pwithsymtable(withsymtable),p,right,levelcount);
|
|
end
|
|
else
|
|
begin
|
|
Message(parser_e_false_with_expr);
|
|
{ try to recover from error }
|
|
if token=_COMMA then
|
|
begin
|
|
consume(_COMMA);
|
|
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 [_SEMICOLON,_END]) 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 : pobjectdef;
|
|
sym : pvarsym;
|
|
old_block_type : tblock_type;
|
|
exceptsymtable : psymtable;
|
|
objname : stringid;
|
|
|
|
begin
|
|
procinfo^.flags:=procinfo^.flags or
|
|
pi_uses_exceptions;
|
|
|
|
p_default:=nil;
|
|
p_specific:=nil;
|
|
|
|
{ read statements to try }
|
|
consume(_TRY);
|
|
first:=nil;
|
|
inc(statement_level);
|
|
|
|
while (token<>_FINALLY) and (token<>_EXCEPT) do
|
|
begin
|
|
if first=nil then
|
|
begin
|
|
last:=cstatementnode.create(nil,statement);
|
|
first:=last;
|
|
end
|
|
else
|
|
begin
|
|
tstatementnode(last).left:=cstatementnode.create(nil,statement);
|
|
last:=tstatementnode(last).left;
|
|
end;
|
|
if not try_to_consume(_SEMICOLON) then
|
|
break;
|
|
emptystats;
|
|
end;
|
|
p_try_block:=cblocknode.create(first);
|
|
|
|
if try_to_consume(_FINALLY) then
|
|
begin
|
|
p_finally_block:=statements_til_end;
|
|
try_statement:=ctryfinallynode.create(p_try_block,p_finally_block);
|
|
dec(statement_level);
|
|
end
|
|
else
|
|
begin
|
|
consume(_EXCEPT);
|
|
old_block_type:=block_type;
|
|
block_type:=bt_except;
|
|
p_specific:=nil;
|
|
if token=_ON then
|
|
{ catch specific exceptions }
|
|
begin
|
|
repeat
|
|
consume(_ON);
|
|
if token=_ID then
|
|
begin
|
|
objname:=pattern;
|
|
getsym(objname,false);
|
|
consume(_ID);
|
|
{ is a explicit name for the exception given ? }
|
|
if try_to_consume(_COLON) then
|
|
begin
|
|
getsym(pattern,true);
|
|
consume(_ID);
|
|
if srsym^.typ=unitsym then
|
|
begin
|
|
consume(_POINT);
|
|
getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
|
|
consume(_ID);
|
|
end;
|
|
if (srsym^.typ=typesym) and
|
|
(ptypesym(srsym)^.restype.def^.deftype=objectdef) and
|
|
pobjectdef(ptypesym(srsym)^.restype.def)^.is_class then
|
|
begin
|
|
ot:=pobjectdef(ptypesym(srsym)^.restype.def);
|
|
sym:=new(pvarsym,initdef(objname,ot));
|
|
end
|
|
else
|
|
begin
|
|
sym:=new(pvarsym,initdef(objname,new(perrordef,init)));
|
|
if (srsym^.typ=typesym) then
|
|
Message1(type_e_class_type_expected,ptypesym(srsym)^.restype.def^.typename)
|
|
else
|
|
Message1(type_e_class_type_expected,ot^.typename);
|
|
end;
|
|
exceptsymtable:=new(psymtable,init(stt_exceptsymtable));
|
|
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
|
|
Message1(sym_e_id_not_found,objname);
|
|
srsym:=generrorsym;
|
|
end;
|
|
{ only exception type }
|
|
if srsym^.typ=unitsym then
|
|
begin
|
|
consume(_POINT);
|
|
getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
|
|
consume(_ID);
|
|
end;
|
|
if (srsym^.typ=typesym) and
|
|
(ptypesym(srsym)^.restype.def^.deftype=objectdef) and
|
|
pobjectdef(ptypesym(srsym)^.restype.def)^.is_class then
|
|
ot:=pobjectdef(ptypesym(srsym)^.restype.def)
|
|
else
|
|
begin
|
|
ot:=pobjectdef(generrordef);
|
|
if (srsym^.typ=typesym) then
|
|
Message1(type_e_class_type_expected,ptypesym(srsym)^.restype.def^.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^.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 }
|
|
tonnode(last).excepttype:=ot;
|
|
tonnode(last).exceptsymtable:=exceptsymtable;
|
|
{ remove exception symtable }
|
|
if assigned(exceptsymtable) then
|
|
dellexlevel;
|
|
if not try_to_consume(_SEMICOLON) then
|
|
break;
|
|
emptystats;
|
|
until (token=_END) or (token=_ELSE);
|
|
if token=_ELSE then
|
|
{ catch the other exceptions }
|
|
begin
|
|
consume(_ELSE);
|
|
p_default:=statements_til_end;
|
|
end
|
|
else
|
|
consume(_END);
|
|
end
|
|
else
|
|
{ catch all exceptions }
|
|
begin
|
|
p_default:=statements_til_end;
|
|
end;
|
|
dec(statement_level);
|
|
|
|
block_type:=old_block_type;
|
|
try_statement:=ctryexceptnode.create(p_try_block,p_specific,p_default);
|
|
end;
|
|
end;
|
|
|
|
|
|
function exit_statement : tnode;
|
|
|
|
var
|
|
p : tnode;
|
|
|
|
begin
|
|
consume(_EXIT);
|
|
if try_to_consume(_LKLAMMER) then
|
|
begin
|
|
p:=comp_expr(true);
|
|
consume(_RKLAMMER);
|
|
if (block_type=bt_except) then
|
|
Message(parser_e_exit_with_argument_not__possible);
|
|
if procinfo^.returntype.def=pdef(voiddef) then
|
|
Message(parser_e_void_function);
|
|
end
|
|
else
|
|
p:=nil;
|
|
p:=cexitnode.create(p);
|
|
// p.resulttype:=procinfo^.returntype.def;
|
|
p.resulttype:=voiddef;
|
|
exit_statement:=p;
|
|
end;
|
|
|
|
|
|
function _asm_statement : tnode;
|
|
var
|
|
asmstat : tasmnode;
|
|
Marker : Pai;
|
|
begin
|
|
Inside_asm_statement:=true;
|
|
case aktasmmode of
|
|
asmmode_none : ; { just be there to allow to a compile without
|
|
any assembler readers }
|
|
{$ifdef i386}
|
|
{$ifndef NoRA386Att}
|
|
asmmode_i386_att:
|
|
asmstat:=tasmnode(ra386att.assemble);
|
|
{$endif NoRA386Att}
|
|
{$ifndef NoRA386Int}
|
|
asmmode_i386_intel:
|
|
asmstat:=tasmnode(ra386int.assemble);
|
|
{$endif NoRA386Int}
|
|
{$ifndef NoRA386Dir}
|
|
asmmode_i386_direct:
|
|
begin
|
|
if not target_asm.allowdirect then
|
|
Message(parser_f_direct_assembler_not_allowed);
|
|
if (pocall_inline in aktprocsym^.definition^.proccalloptions) then
|
|
Begin
|
|
Message1(parser_w_not_supported_for_inline,'direct asm');
|
|
Message(parser_w_inlining_disabled);
|
|
exclude(aktprocsym^.definition^.proccalloptions,pocall_inline);
|
|
End;
|
|
asmstat:=tasmnode(ra386dir.assemble);
|
|
end;
|
|
{$endif NoRA386Dir}
|
|
{$endif}
|
|
{$ifdef m68k}
|
|
{$ifndef NoRA68kMot}
|
|
asmmode_m68k_mot:
|
|
asmstat:=tasmnode(ra68kmot.assemble);
|
|
{$endif NoRA68kMot}
|
|
{$endif}
|
|
else
|
|
Message(parser_f_assembler_reader_not_supported);
|
|
end;
|
|
|
|
{ Read first the _ASM statement }
|
|
consume(_ASM);
|
|
|
|
{$ifndef newcg}
|
|
{ END is read }
|
|
if try_to_consume(_LECKKLAMMER) then
|
|
begin
|
|
{ it's possible to specify the modified registers }
|
|
include(asmstat.flags,nf_object_preserved);
|
|
if token<>_RECKKLAMMER then
|
|
repeat
|
|
{ uppercase, because it's a CSTRING }
|
|
uppervar(pattern);
|
|
{$ifdef i386}
|
|
if pattern='EAX' then
|
|
usedinproc:=usedinproc or ($80 shr byte(R_EAX))
|
|
else if pattern='EBX' then
|
|
usedinproc:=usedinproc or ($80 shr byte(R_EBX))
|
|
else if pattern='ECX' then
|
|
usedinproc:=usedinproc or ($80 shr byte(R_ECX))
|
|
else if pattern='EDX' then
|
|
usedinproc:=usedinproc or ($80 shr byte(R_EDX))
|
|
else if pattern='ESI' then
|
|
begin
|
|
usedinproc:=usedinproc or ($80 shr byte(R_ESI));
|
|
exclude(asmstat.flags,nf_object_preserved);
|
|
end
|
|
else if pattern='EDI' then
|
|
usedinproc:=usedinproc or ($80 shr byte(R_EDI))
|
|
{$endif i386}
|
|
{$ifdef m68k}
|
|
if pattern='D0' then
|
|
usedinproc:=usedinproc or ($800 shr word(R_D0))
|
|
else if pattern='D1' then
|
|
usedinproc:=usedinproc or ($800 shr word(R_D1))
|
|
else if pattern='D6' then
|
|
usedinproc:=usedinproc or ($800 shr word(R_D6))
|
|
else if pattern='A0' then
|
|
usedinproc:=usedinproc or ($800 shr word(R_A0))
|
|
else if pattern='A1' then
|
|
usedinproc:=usedinproc or ($800 shr word(R_A1))
|
|
{$endif m68k}
|
|
else consume(_RECKKLAMMER);
|
|
consume(_CSTRING);
|
|
if not try_to_consume(_COMMA) then
|
|
break;
|
|
until false;
|
|
consume(_RECKKLAMMER);
|
|
end
|
|
else usedinproc:=$ff;
|
|
{$endif newcg}
|
|
|
|
{ mark the start and the end of the assembler block
|
|
this is needed for the optimizer }
|
|
If Assigned(AsmStat.p_asm) Then
|
|
Begin
|
|
Marker := New(Pai_Marker, Init(AsmBlockStart));
|
|
AsmStat.p_asm^.Insert(Marker);
|
|
Marker := New(Pai_Marker, Init(AsmBlockEnd));
|
|
AsmStat.p_asm^.Concat(Marker);
|
|
End;
|
|
Inside_asm_statement:=false;
|
|
_asm_statement:=asmstat;
|
|
end;
|
|
|
|
|
|
function new_dispose_statement : tnode;
|
|
var
|
|
p,p2 : tnode;
|
|
again : boolean; { dummy for do_proc_call }
|
|
destructorname : stringid;
|
|
sym : psym;
|
|
classh : pobjectdef;
|
|
pd,pd2 : pdef;
|
|
destructorpos,
|
|
storepos : tfileposinfo;
|
|
is_new : boolean;
|
|
begin
|
|
if try_to_consume(_NEW) then
|
|
is_new:=true
|
|
else
|
|
begin
|
|
consume(_DISPOSE);
|
|
is_new:=false;
|
|
end;
|
|
consume(_LKLAMMER);
|
|
p:=comp_expr(true);
|
|
{ calc return type }
|
|
cleartempgen;
|
|
do_firstpass(p);
|
|
set_varstate(p,(not is_new));
|
|
{ constructor,destructor specified }
|
|
if try_to_consume(_COMMA) then
|
|
begin
|
|
{ extended syntax of new and dispose }
|
|
{ function styled new is handled in factor }
|
|
{ destructors have no parameters }
|
|
destructorname:=pattern;
|
|
destructorpos:=tokenpos;
|
|
consume(_ID);
|
|
|
|
pd:=p.resulttype;
|
|
if pd=nil then
|
|
pd:=generrordef;
|
|
pd2:=pd;
|
|
if (pd^.deftype<>pointerdef) then
|
|
begin
|
|
Message1(type_e_pointer_type_expected,pd^.typename);
|
|
p.free;
|
|
p:=factor(false);
|
|
p.free;
|
|
consume(_RKLAMMER);
|
|
new_dispose_statement:=cerrornode.create;
|
|
exit;
|
|
end;
|
|
{ first parameter must be an object or class }
|
|
if ppointerdef(pd)^.pointertype.def^.deftype<>objectdef then
|
|
begin
|
|
Message(parser_e_pointer_to_class_expected);
|
|
p.free;
|
|
new_dispose_statement:=factor(false);
|
|
consume_all_until(_RKLAMMER);
|
|
consume(_RKLAMMER);
|
|
exit;
|
|
end;
|
|
{ check, if the first parameter is a pointer to a _class_ }
|
|
classh:=pobjectdef(ppointerdef(pd)^.pointertype.def);
|
|
if classh^.is_class then
|
|
begin
|
|
Message(parser_e_no_new_or_dispose_for_classes);
|
|
new_dispose_statement:=factor(false);
|
|
consume_all_until(_RKLAMMER);
|
|
consume(_RKLAMMER);
|
|
exit;
|
|
end;
|
|
{ search cons-/destructor, also in parent classes }
|
|
storepos:=tokenpos;
|
|
tokenpos:=destructorpos;
|
|
sym:=search_class_member(classh,destructorname);
|
|
tokenpos:=storepos;
|
|
|
|
{ the second parameter of new/dispose must be a call }
|
|
{ to a cons-/destructor }
|
|
if (not assigned(sym)) or (sym^.typ<>procsym) then
|
|
begin
|
|
if is_new then
|
|
Message(parser_e_expr_have_to_be_constructor_call)
|
|
else
|
|
Message(parser_e_expr_have_to_be_destructor_call);
|
|
p.free;
|
|
new_dispose_statement:=cerrornode.create;
|
|
end
|
|
else
|
|
begin
|
|
if is_new then
|
|
p2:=chnewnode.create
|
|
else
|
|
p2:=chdisposenode.create(p);
|
|
if is_new then
|
|
begin
|
|
{ Constructors can take parameters.}
|
|
p2.resulttype:=ppointerdef(pd)^.pointertype.def;
|
|
do_member_read(false,sym,p2,pd,again);
|
|
end
|
|
else
|
|
begin
|
|
if (m_tp in aktmodeswitches) then
|
|
begin
|
|
{ Constructors can take parameters.}
|
|
p2.resulttype:=ppointerdef(pd)^.pointertype.def;
|
|
do_member_read(false,sym,p2,pd,again);
|
|
end
|
|
else
|
|
begin
|
|
p2:=ccallnode.create(pprocsym(sym),srsymtable,p2);
|
|
{ support dispose(p,done()); }
|
|
if try_to_consume(_LKLAMMER) then
|
|
begin
|
|
if not try_to_consume(_RKLAMMER) then
|
|
begin
|
|
Message(parser_e_no_paras_for_destructor);
|
|
consume_all_until(_RKLAMMER);
|
|
consume(_RKLAMMER);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ we need the real called method }
|
|
cleartempgen;
|
|
do_firstpass(p2);
|
|
|
|
if not codegenerror then
|
|
begin
|
|
if is_new then
|
|
begin
|
|
if (tcallnode(p2).procdefinition^.proctypeoption<>potype_constructor) then
|
|
Message(parser_e_expr_have_to_be_constructor_call);
|
|
p2:=cassignmentnode.create(p,cnewnode.create(p2));
|
|
tassignmentnode(p2).right.resulttype:=pd2;
|
|
end
|
|
else
|
|
begin
|
|
if (tcallnode(p2).procdefinition^.proctypeoption<>potype_destructor) then
|
|
Message(parser_e_expr_have_to_be_destructor_call);
|
|
end;
|
|
end;
|
|
new_dispose_statement:=p2;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if p.resulttype=nil then
|
|
p.resulttype:=generrordef;
|
|
if (p.resulttype^.deftype<>pointerdef) then
|
|
Begin
|
|
Message1(type_e_pointer_type_expected,p.resulttype^.typename);
|
|
new_dispose_statement:=cerrornode.create;
|
|
end
|
|
else
|
|
begin
|
|
if (ppointerdef(p.resulttype)^.pointertype.def^.deftype=objectdef) and
|
|
(oo_has_vmt in pobjectdef(ppointerdef(p.resulttype)^.pointertype.def)^.objectoptions) then
|
|
Message(parser_w_use_extended_syntax_for_objects);
|
|
if (ppointerdef(p.resulttype)^.pointertype.def^.deftype=orddef) and
|
|
(porddef(ppointerdef(p.resulttype)^.pointertype.def)^.typ=uvoid) then
|
|
begin
|
|
if (m_tp in aktmodeswitches) or
|
|
(m_delphi in aktmodeswitches) then
|
|
Message(parser_w_no_new_dispose_on_void_pointers)
|
|
else
|
|
Message(parser_e_no_new_dispose_on_void_pointers);
|
|
end;
|
|
|
|
if is_new then
|
|
new_dispose_statement:=csimplenewdisposenode.create(simplenewn,p)
|
|
else
|
|
new_dispose_statement:=csimplenewdisposenode.create(simpledisposen,p);
|
|
end;
|
|
end;
|
|
consume(_RKLAMMER);
|
|
end;
|
|
|
|
|
|
function statement : tnode;
|
|
var
|
|
p : tnode;
|
|
code : tnode;
|
|
filepos : tfileposinfo;
|
|
sr : plabelsym;
|
|
label
|
|
ready;
|
|
begin
|
|
filepos:=tokenpos;
|
|
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
|
|
getsym(pattern,true);
|
|
consume(token);
|
|
if srsym^.typ<>labelsym then
|
|
begin
|
|
Message(sym_e_id_is_no_label_id);
|
|
code:=cerrornode.create;
|
|
end
|
|
else
|
|
begin
|
|
code:=cgotonode.create(plabelsym(srsym)^.lab);
|
|
tgotonode(code).labsym:=plabelsym(srsym);
|
|
{ set flag that this label is used }
|
|
plabelsym(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;
|
|
_NEW,
|
|
_DISPOSE :
|
|
code:=new_dispose_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 (aktprocsym^.definition^.proctypeoption<>potype_constructor) then
|
|
Message(parser_e_fail_only_in_constructor);
|
|
consume(_FAIL);
|
|
code:=cfailnode.create;
|
|
end;
|
|
_EXIT :
|
|
code:=exit_statement;
|
|
_ASM :
|
|
code:=_asm_statement;
|
|
_EOF :
|
|
Message(scan_f_end_of_file);
|
|
else
|
|
begin
|
|
if (token in [_INTCONST,_ID]) then
|
|
begin
|
|
getsym(pattern,true);
|
|
lastsymknown:=true;
|
|
lastsrsym:=srsym;
|
|
{ it is NOT necessarily the owner
|
|
it can be a withsymtable !!! }
|
|
lastsrsymtable:=srsymtable;
|
|
if assigned(srsym) and (srsym^.typ=labelsym) then
|
|
begin
|
|
consume(token);
|
|
consume(_COLON);
|
|
{ we must preserve srsym to set code later }
|
|
sr:=plabelsym(srsym);
|
|
if sr^.defined then
|
|
Message(sym_e_label_already_defined);
|
|
sr^.defined:=true;
|
|
|
|
{ statement modifies srsym }
|
|
lastsymknown:=false;
|
|
{ the pointer to the following instruction }
|
|
{ isn't a very clean way }
|
|
code:=clabelnode.create(sr^.lab,statement{$ifdef FPCPROCVAR}(){$endif});
|
|
sr^.code:=code;
|
|
{ sorry, but here is a jump the easiest way }
|
|
goto ready;
|
|
end;
|
|
end;
|
|
p:=expr;
|
|
if not(p.nodetype in [calln,assignn,breakn,inlinen,continuen]) then
|
|
Message(cg_e_illegal_expression);
|
|
{ specify that we don't use the value returned by the call }
|
|
{ Question : can this be also improtant
|
|
for inlinen ??
|
|
it 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;
|
|
ready:
|
|
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:=tokenpos;
|
|
consume(starttoken);
|
|
inc(statement_level);
|
|
|
|
while not(token in [_END,_FINALIZATION]) do
|
|
begin
|
|
if first=nil then
|
|
begin
|
|
last:=cstatementnode.create(nil,statement);
|
|
first:=last;
|
|
end
|
|
else
|
|
begin
|
|
tstatementnode(last).left:=cstatementnode.create(nil,statement);
|
|
last:=tstatementnode(last).left;
|
|
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;
|
|
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);
|
|
|
|
dec(statement_level);
|
|
|
|
last:=cblocknode.create(first);
|
|
last.set_tree_filepos(filepos);
|
|
statement_block:=last;
|
|
end;
|
|
|
|
|
|
function assembler_block : tnode;
|
|
|
|
begin
|
|
{ temporary space is set, while the BEGIN of the procedure }
|
|
if symtablestack^.symtabletype=localsymtable then
|
|
procinfo^.firsttemp_offset := -symtablestack^.datasize
|
|
else
|
|
procinfo^.firsttemp_offset := 0;
|
|
|
|
{ assembler code does not allocate }
|
|
{ space for the return value }
|
|
if procinfo^.returntype.def<>pdef(voiddef) then
|
|
begin
|
|
if ret_in_acc(procinfo^.returntype.def) then
|
|
begin
|
|
{ in assembler code the result should be directly in %eax
|
|
procinfo^.retoffset:=procinfo^.firsttemp-procinfo^.retdef^.size;
|
|
procinfo^.firsttemp:=procinfo^.retoffset; }
|
|
|
|
{$ifndef newcg}
|
|
{$ifdef i386}
|
|
usedinproc:=usedinproc or ($80 shr byte(R_EAX))
|
|
{$endif}
|
|
{$ifdef m68k}
|
|
usedinproc:=usedinproc or ($800 shr word(R_D0))
|
|
{$endif}
|
|
{$endif newcg}
|
|
end
|
|
{
|
|
else if not is_fpu(procinfo^.retdef) then
|
|
should we allow assembler functions of big elements ?
|
|
YES (FK)!!
|
|
Message(parser_e_asm_incomp_with_function_return);
|
|
}
|
|
end;
|
|
{ set the framepointer to esp for assembler functions }
|
|
{ but only if the are no local variables }
|
|
{ added no parameter also (PM) }
|
|
{ disable for methods, because self pointer is expected }
|
|
{ at -8(%ebp) (JM) }
|
|
{ why if se use %esp then self is still at the correct address PM }
|
|
if {not(assigned(procinfo^._class)) and}
|
|
(po_assembler in aktprocsym^.definition^.procoptions) and
|
|
(aktprocsym^.definition^.localst^.datasize=0) and
|
|
(aktprocsym^.definition^.parast^.datasize=0) and
|
|
not(ret_in_param(aktprocsym^.definition^.rettype.def)) then
|
|
begin
|
|
procinfo^.framepointer:=stack_pointer;
|
|
{ set the right value for parameters }
|
|
dec(aktprocsym^.definition^.parast^.address_fixup,target_os.size_of_pointer);
|
|
dec(procinfo^.para_offset,target_os.size_of_pointer);
|
|
end;
|
|
{ force the asm statement }
|
|
if token<>_ASM then
|
|
consume(_ASM);
|
|
procinfo^.Flags := procinfo^.Flags Or pi_is_assembler;
|
|
assembler_block:=_asm_statement;
|
|
{ becuase the END is already read we need to get the
|
|
last_endtoken_filepos here (PFV) }
|
|
last_endtoken_filepos:=tokenpos;
|
|
end;
|
|
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.11 2000-10-14 21:52:56 peter
|
|
* fixed memory leaks
|
|
|
|
Revision 1.10 2000/10/14 10:14:52 peter
|
|
* moehrendorf oct 2000 rewrite
|
|
|
|
Revision 1.9 2000/10/01 19:48:25 peter
|
|
* lot of compile updates for cg11
|
|
|
|
Revision 1.8 2000/09/24 21:19:50 peter
|
|
* delphi compile fixes
|
|
|
|
Revision 1.7 2000/09/24 15:06:24 peter
|
|
* use defines.inc
|
|
|
|
Revision 1.6 2000/08/27 16:11:52 peter
|
|
* moved some util functions from globals,cobjects to cutils
|
|
* splitted files into finput,fmodule
|
|
|
|
Revision 1.5 2000/08/12 15:41:15 peter
|
|
* fixed bug 1096 (merged)
|
|
|
|
Revision 1.4 2000/08/12 06:46:06 florian
|
|
+ case statement for int64/qword implemented
|
|
|
|
Revision 1.3 2000/07/13 12:08:27 michael
|
|
+ patched to 1.1.0 with former 1.09patch from peter
|
|
|
|
Revision 1.2 2000/07/13 11:32:45 michael
|
|
+ removed logs
|
|
|
|
} |