paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 11:48:10 +02:00
Code Issues Packages Projects Releases Wiki Activity
5f20356336
fpc/compiler/pass_1.pas
florian 01575ac687 - switch -Sa removed 
- support of a:=b:=0 removed
1998-03-26 11:18:30 +00:00

4710 lines
174 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (c) 1996-98 by Florian Klaempfl
This unit implements the first pass of the code generator
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.
****************************************************************************
}
{$ifdef tp}
{$F+}
{$endif tp}
unit pass_1;
interface
uses tree;
function do_firstpass(var p : ptree) : boolean;
implementation
uses
objects,cobjects,verbose,systems,globals,aasm,symtable,
types,strings,hcodegen,files
{$ifdef i386}
,i386
,tgeni386
{$endif}
{$ifdef m68k}
,m68k
,tgen68k
{$endif}
{$ifdef UseBrowser}
,browser
{$endif UseBrowser}
;
{ firstcallparan without varspez
we don't count the ref }
const
count_ref : boolean = true;
procedure error(const t : tmsgconst);
begin
if not(codegenerror) then
verbose.Message(t);
codegenerror:=true;
end;
procedure firstpass(var p : ptree);forward;
{ marks an lvalue as "unregable" }
procedure make_not_regable(p : ptree);
begin
case p^.treetype of
typeconvn : make_not_regable(p^.left);
loadn : if p^.symtableentry^.typ=varsym then
pvarsym(p^.symtableentry)^.regable:=false;
end;
end;
{ calculates the needed registers for a binary operator }
procedure calcregisters(p : ptree;r32,fpu,mmx : word);
begin
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
{$endif SUPPORT_MMX}
{ Nur wenn links und rechts ein Unterschied < ben<65>tige Anzahl ist, }
{ wird ein zus<75>tzliches Register ben<65>tigt, da es dann keinen }
{ schwierigeren Ast gibt, welcher erst ausgewertet werden kann }
if (abs(p^.left^.registers32-p^.right^.registers32)<r32) then
inc(p^.registers32,r32);
if (abs(p^.left^.registersfpu-p^.right^.registersfpu)<fpu) then
inc(p^.registersfpu,fpu);
{$ifdef SUPPORT_MMX}
if (abs(p^.left^.registersmmx-p^.right^.registersmmx)<mmx) then
inc(p^.registersmmx,mmx);
{$endif SUPPORT_MMX}
{ error message, if more than 8 floating point }
{ registers are needed }
if p^.registersfpu>8 then
Message(cg_e_too_complex_expr);
end;
function both_rm(p : ptree) : boolean;
begin
both_rm:=(p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) and
(p^.right^.location.loc in [LOC_MEM,LOC_REFERENCE]);
end;
function isconvertable(def_from,def_to : pdef;
var doconv : tconverttype;fromtreetype : ttreetyp) : boolean;
{ from_is_cstring mu<6D> true sein, wenn def_from die Definition einer }
{ Stringkonstanten ist, n<>tig wegen der Konvertierung von String- }
{ konstante zu nullterminiertem String }
{ Hilfsliste: u8bit,s32bit,uvoid,
bool8bit,uchar,s8bit,s16bit,u16bit,u32bit }
const
basedefconverts : array[u8bit..u32bit,u8bit..u32bit] of tconverttype =
{u8bit}
((tc_only_rangechecks32bit,tc_u8bit_2_s32bit,tc_not_possible,
tc_not_possible,tc_not_possible,tc_only_rangechecks32bit,tc_u8bit_2_s16bit,
tc_u8bit_2_u16bit,{tc_not_possible}tc_u8bit_2_u32bit),
{s32bit}
(tc_s32bit_2_u8bit,tc_only_rangechecks32bit,tc_not_possible,
tc_not_possible,tc_not_possible,tc_s32bit_2_s8bit,
tc_s32bit_2_s16bit,tc_s32bit_2_u16bit,{tc_not_possible}tc_s32bit_2_u32bit),
{uvoid}
(tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible,
tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible,
tc_not_possible),
{bool8bit}
(tc_not_possible,tc_not_possible,tc_not_possible,
tc_only_rangechecks32bit,tc_not_possible,tc_not_possible,tc_not_possible,
tc_not_possible,tc_not_possible),
{uchar}
(tc_not_possible,tc_not_possible,tc_not_possible,
tc_not_possible,tc_only_rangechecks32bit,tc_not_possible,tc_not_possible,
tc_not_possible,tc_not_possible),
{s8bit}
(tc_only_rangechecks32bit,tc_s8bit_2_s32bit,tc_not_possible,
tc_not_possible,tc_not_possible,tc_only_rangechecks32bit,tc_s8bit_2_s16bit,
tc_s8bit_2_u16bit,{tc_not_possible}tc_s8bit_2_u32bit),
{s16bit}
(tc_s16bit_2_u8bit,tc_s16bit_2_s32bit,tc_not_possible,
tc_not_possible,tc_not_possible,tc_s16bit_2_s8bit,tc_only_rangechecks32bit,
tc_only_rangechecks32bit,{tc_not_possible}tc_s8bit_2_u32bit),
{u16bit}
(tc_u16bit_2_u8bit,tc_u16bit_2_s32bit,tc_not_possible,
tc_not_possible,tc_not_possible,tc_u16bit_2_s8bit,tc_only_rangechecks32bit,
tc_only_rangechecks32bit,{tc_not_possible}tc_u16bit_2_u32bit),
{u32bit}
(tc_not_possible,{tc_not_possible}tc_u32bit_2_s32bit,tc_not_possible,
tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible,
tc_not_possible,tc_only_rangechecks32bit)
);
var
b : boolean;
begin
b:=false;
if (not assigned(def_from)) or (not assigned(def_to)) then
begin
isconvertable:=false;
exit;
end;
if (def_from^.deftype=orddef) and (def_to^.deftype=orddef) then
begin
doconv:=basedefconverts[porddef(def_from)^.typ,porddef(def_to)^.typ];
if doconv<>tc_not_possible then
b:=true;
end
else if (def_from^.deftype=orddef) and (def_to^.deftype=floatdef) then
begin
if pfloatdef(def_to)^.typ=f32bit then
doconv:=tc_int_2_fix
else
doconv:=tc_int_2_real;
b:=true;
end
else if (def_from^.deftype=floatdef) and (def_to^.deftype=floatdef) then
begin
if pfloatdef(def_from)^.typ=pfloatdef(def_to)^.typ then
doconv:=tc_equal
else
begin
if pfloatdef(def_from)^.typ=f32bit then
doconv:=tc_fix_2_real
else if pfloatdef(def_to)^.typ=f32bit then
doconv:=tc_real_2_fix
else
doconv:=tc_real_2_real;
{ comp isn't a floating type }
{$ifdef i386}
if (pfloatdef(def_to)^.typ=s64bit) then
Message(parser_w_convert_real_2_comp);
{$endif}
end;
b:=true;
end
else if (def_from^.deftype=pointerdef) and (def_to^.deftype=arraydef) and
(parraydef(def_to)^.lowrange=0) and
is_equal(ppointerdef(def_from)^.definition,
parraydef(def_to)^.definition) then
begin
doconv:=tc_pointer_to_array;
b:=true;
end
else if (def_from^.deftype=arraydef) and (def_to^.deftype=pointerdef) and
(parraydef(def_from)^.lowrange=0) and
is_equal(parraydef(def_from)^.definition,
ppointerdef(def_to)^.definition) then
begin
doconv:=tc_array_to_pointer;
b:=true;
end
{ typed files are all equal to the abstract file type
name TYPEDFILE in system.pp in is_equal in types.pas
the problem is that it sholud be also compatible to FILE
but this would leed to a problem for ASSIGN RESET and REWRITE
when trying to find the good overloaded function !!
so all file function are doubled in system.pp
this is not very beautiful !!}
else if (def_from^.deftype=filedef) and (def_to^.deftype=filedef) and
(
(
(pfiledef(def_from)^.filetype = ft_typed) and
(pfiledef(def_to)^.filetype = ft_typed) and
(
(pfiledef(def_from)^.typed_as = pdef(voiddef)) or
(pfiledef(def_to)^.typed_as = pdef(voiddef))
)
) or
(
(
(pfiledef(def_from)^.filetype = ft_untyped) and
(pfiledef(def_to)^.filetype = ft_typed)
) or
(
(pfiledef(def_from)^.filetype = ft_typed) and
(pfiledef(def_to)^.filetype = ft_untyped)
)
)
) then
begin
doconv:=tc_equal;
b:=true;
end
{ object pascal objects }
else if (def_from^.deftype=objectdef) and (def_to^.deftype=objectdef) and
pobjectdef(def_from)^.isclass and pobjectdef(def_to)^.isclass then
begin
doconv:=tc_equal;
b:=pobjectdef(def_from)^.isrelated(
pobjectdef(def_to));
end
{ class reference types }
else if (def_from^.deftype=classrefdef) and (def_from^.deftype=classrefdef) then
begin
doconv:=tc_equal;
b:=pobjectdef(pclassrefdef(def_from)^.definition)^.isrelated(
pobjectdef(pclassrefdef(def_to)^.definition));
end
else if (def_from^.deftype=pointerdef) and (def_to^.deftype=pointerdef) then
begin
{ child class pointer can be assigned to anchestor pointers }
if (
(ppointerdef(def_from)^.definition^.deftype=objectdef) and
(ppointerdef(def_to)^.definition^.deftype=objectdef) and
pobjectdef(ppointerdef(def_from)^.definition)^.isrelated(
pobjectdef(ppointerdef(def_to)^.definition))
) or
{ all pointers can be assigned to void-pointer }
is_equal(ppointerdef(def_to)^.definition,voiddef) or
{ in my opnion, is this not clean pascal }
{ well, but it's handy to use, it isn't ? (FK) }
is_equal(ppointerdef(def_from)^.definition,voiddef) then
begin
doconv:=tc_equal;
b:=true;
end
end
else
if (def_from^.deftype=stringdef) and (def_to^.deftype=stringdef) then
begin
doconv:=tc_string_to_string;
b:=true;
end
else
{ char to string}
if is_equal(def_from,cchardef) and
(def_to^.deftype=stringdef) then
begin
doconv:=tc_char_to_string;
b:=true;
end
else
{ string constant to zero terminated string constant }
if (fromtreetype=stringconstn) and
(
(def_to^.deftype=pointerdef) and
is_equal(Ppointerdef(def_to)^.definition,cchardef)
) then
begin
doconv:=tc_cstring_charpointer;
b:=true;
end
else
{ array of char to string }
{ the length check is done by the firstpass of this node }
if (def_from^.deftype=stringdef) and
(
(def_to^.deftype=arraydef) and
is_equal(parraydef(def_to)^.definition,cchardef)
) then
begin
doconv:=tc_string_chararray;
b:=true;
end
else
{ string to array of char }
{ the length check is done by the firstpass of this node }
if (
(def_from^.deftype=arraydef) and
is_equal(parraydef(def_from)^.definition,cchardef)
) and
(def_to^.deftype=stringdef) then
begin
doconv:=tc_chararray_2_string;
b:=true;
end
else
if (fromtreetype=ordconstn) and is_equal(def_from,cchardef) then
begin
if (def_to^.deftype=pointerdef) and
is_equal(ppointerdef(def_to)^.definition,cchardef) then
begin
doconv:=tc_cchar_charpointer;
b:=true;
end;
end
else
if (def_to^.deftype=procvardef) and (def_from^.deftype=procdef) then
begin
def_from^.deftype:=procvardef;
doconv:=tc_proc2procvar;
b:=is_equal(def_from,def_to);
def_from^.deftype:=procdef;
end
else
{ nil is compatible with class instances }
if (fromtreetype=niln) and (def_to^.deftype=objectdef)
and (pobjectdef(def_to)^.isclass) then
begin
doconv:=tc_equal;
b:=true;
end
else
{ nil is compatible with class references }
if (fromtreetype=niln) and (def_to^.deftype=classrefdef) then
begin
doconv:=tc_equal;
b:=true;
end
{ procedure variable can be assigned to an void pointer }
{ Not anymore. Use the @ operator now.}
else
if not (cs_tp_compatible in aktswitches) then
begin
if (def_from^.deftype=procvardef) and
(def_to^.deftype=pointerdef) and
(ppointerdef(def_to)^.definition^.deftype=orddef) and
(porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
begin
doconv:=tc_equal;
b:=true;
end;
end;
isconvertable:=b;
end;
procedure firsterror(var p : ptree);
begin
p^.error:=true;
codegenerror:=true;
p^.resulttype:=generrordef;
end;
procedure firstload(var p : ptree);
begin
p^.location.loc:=LOC_REFERENCE;
p^.registers32:=0;
p^.registersfpu:=0;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=0;
{$endif SUPPORT_MMX}
clear_reference(p^.location.reference);
{$ifdef TEST_FUNCRET}
if p^.symtableentry^.typ=funcretsym then
begin
putnode(p);
p:=genzeronode(funcretn);
p^.funcretprocinfo:=pprocinfo(pfuncretsym(p^.symtableentry)^.funcretprocinfo);
p^.retdef:=pfuncretsym(p^.symtableentry)^.retdef;
firstpass(p);
exit;
end;
{$endif TEST_FUNCRET}
if p^.symtableentry^.typ=absolutesym then
begin
p^.resulttype:=pabsolutesym(p^.symtableentry)^.definition;
if pabsolutesym(p^.symtableentry)^.abstyp=tovar then
p^.symtableentry:=pabsolutesym(p^.symtableentry)^.ref;
p^.symtable:=p^.symtableentry^.owner;
p^.is_absolute:=true;
end;
case p^.symtableentry^.typ of
absolutesym :;
varsym :
begin
if not(p^.is_absolute) and (p^.resulttype=nil) then
p^.resulttype:=pvarsym(p^.symtableentry)^.definition;
if ((p^.symtable^.symtabletype=parasymtable) or
(p^.symtable^.symtabletype=localsymtable)) and
(lexlevel>p^.symtable^.symtablelevel) then
begin
{ sollte sich die Variable in einem anderen Stackframe }
{ befinden, so brauchen wir ein Register zum Dereferenceieren }
if (p^.symtable^.symtablelevel)>0 then
begin
p^.registers32:=1;
{ au<61>erdem kann sie nicht mehr in ein Register
geladen werden }
pvarsym(p^.symtableentry)^.regable:=false;
end;
end;
if (pvarsym(p^.symtableentry)^.varspez=vs_const) then
p^.location.loc:=LOC_MEM;
{ we need a register for call by reference parameters }
if (pvarsym(p^.symtableentry)^.varspez=vs_var) or
((pvarsym(p^.symtableentry)^.varspez=vs_const) and
dont_copy_const_param(pvarsym(p^.symtableentry)^.definition)
) then
p^.registers32:=1;
if p^.symtable^.symtabletype=withsymtable then
p^.registers32:=1;
{ a class variable is a pointer !!!
yes, but we have to resolve the reference in an
appropriate tree node (FK)
if (pvarsym(p^.symtableentry)^.definition^.deftype=objectdef) and
((pobjectdef(pvarsym(p^.symtableentry)^.definition)^.options and oois_class)<>0) then
p^.registers32:=1;
}
{ count variable references }
if must_be_valid and p^.is_first then
begin
if pvarsym(p^.symtableentry)^.is_valid=2 then
if (assigned(pvarsym(p^.symtableentry)^.owner) and assigned(aktprocsym)
and (pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst)) then
Message1(sym_n_uninitialized_local_variable,pvarsym(p^.symtableentry)^.name);
end;
if count_ref then
begin
if (p^.is_first) then
begin
if (pvarsym(p^.symtableentry)^.is_valid=2) then
pvarsym(p^.symtableentry)^.is_valid:=1;
p^.is_first:=false;
end;
end;
{ this will create problem with local var set by
under_procedures
if (assigned(pvarsym(p^.symtableentry)^.owner) and assigned(aktprocsym)
and ((pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst)
or (pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst))) then }
if t_times<1 then
inc(pvarsym(p^.symtableentry)^.refs)
else
inc(pvarsym(p^.symtableentry)^.refs,t_times);
end;
typedconstsym :
if not p^.is_absolute then
p^.resulttype:=ptypedconstsym(p^.symtableentry)^.definition;
procsym :
begin
if assigned(pprocsym(p^.symtableentry)^.definition^.nextoverloaded) then
Message(parser_e_no_overloaded_procvars);
p^.resulttype:=pprocsym(p^.symtableentry)^.definition;
end;
else internalerror(3);
end;
end;
procedure firstadd(var p : ptree);
var
lt,rt : ttreetyp;
t : ptree;
rv,lv : longint;
rvd,lvd : {double}bestreal;
rd,ld : pdef;
concatstrings : boolean;
{ to evalute const sets }
resultset : pconstset;
i : longint;
b : boolean;
s1,s2:^string;
{ this totally forgets to set the pi_do_call flag !! }
label
no_overload;
begin
{ first do the two subtrees }
firstpass(p^.left);
firstpass(p^.right);
if codegenerror then
exit;
new(s1);
new(s2);
{ overloaded operator ? }
if (p^.treetype=caretn) or
(p^.left^.resulttype^.deftype=recorddef) or
{ <> and = are defined for classes }
((p^.left^.resulttype^.deftype=objectdef) and
(not(pobjectdef(p^.left^.resulttype)^.isclass) or
not(p^.treetype in [equaln,unequaln])
)
) or
(p^.right^.resulttype^.deftype=recorddef) or
{ <> and = are defined for classes }
((p^.right^.resulttype^.deftype=objectdef) and
(not(pobjectdef(p^.right^.resulttype)^.isclass) or
not(p^.treetype in [equaln,unequaln])
)
) then
begin
{!!!!!!!!! handle paras }
case p^.treetype of
{ the nil as symtable signs firstcalln that this is
an overloaded operator }
addn:
t:=gencallnode(overloaded_operators[plus],nil);
subn:
t:=gencallnode(overloaded_operators[minus],nil);
muln:
t:=gencallnode(overloaded_operators[star],nil);
caretn:
t:=gencallnode(overloaded_operators[caret],nil);
slashn:
t:=gencallnode(overloaded_operators[slash],nil);
ltn:
t:=gencallnode(overloaded_operators[globals.lt],nil);
gtn:
t:=gencallnode(overloaded_operators[gt],nil);
lten:
t:=gencallnode(overloaded_operators[lte],nil);
gten:
t:=gencallnode(overloaded_operators[gte],nil);
equaln,unequaln :
t:=gencallnode(overloaded_operators[equal],nil);
else goto no_overload;
end;
{ we have to convert p^.left and p^.right into
callparanodes }
t^.left:=gencallparanode(p^.left,nil);
t^.left:=gencallparanode(p^.right,t^.left);
if t^.symtableprocentry=nil then
Message(parser_e_operator_not_overloaded);
if p^.treetype=unequaln then
t:=gensinglenode(notn,t);
dispose(s1);
dispose(s2);
firstpass(t);
putnode(p);
p:=t;
exit;
end;
no_overload:
{ compact consts }
lt:=p^.left^.treetype;
rt:=p^.right^.treetype;
{ convert int consts to real consts, if the }
{ other operand is a real const }
if is_constintnode(p^.left) and
(rt=realconstn) then
begin
t:=genrealconstnode(p^.left^.value);
disposetree(p^.left);
p^.left:=t;
lt:=realconstn;
end;
if is_constintnode(p^.right) and
(lt=realconstn) then
begin
t:=genrealconstnode(p^.right^.value);
disposetree(p^.right);
p^.right:=t;
rt:=realconstn;
end;
if is_constintnode(p^.left) and
is_constintnode(p^.right) then
begin
lv:=p^.left^.value;
rv:=p^.right^.value;
case p^.treetype of
addn:
t:=genordinalconstnode(lv+rv,s32bitdef);
subn:
t:=genordinalconstnode(lv-rv,s32bitdef);
muln:
t:=genordinalconstnode(lv*rv,s32bitdef);
xorn:
t:=genordinalconstnode(lv xor rv,s32bitdef);
orn:
t:=genordinalconstnode(lv or rv,s32bitdef);
andn:
t:=genordinalconstnode(lv and rv,s32bitdef);
ltn:
t:=genordinalconstnode(ord(lv<rv),booldef);
lten:
t:=genordinalconstnode(ord(lv<=rv),booldef);
gtn:
t:=genordinalconstnode(ord(lv>rv),booldef);
gten:
t:=genordinalconstnode(ord(lv>=rv),booldef);
equaln:
t:=genordinalconstnode(ord(lv=rv),booldef);
unequaln:
t:=genordinalconstnode(ord(lv<>rv),booldef);
slashn :
begin
{ int/int becomes a real }
t:=genrealconstnode(int(lv)/int(rv));
firstpass(t);
end;
else
Message(sym_e_type_mismatch);
end;
disposetree(p);
dispose(s1);
dispose(s2);
p:=t;
exit;
end
else
{ real constants }
if (lt=realconstn) and (rt=realconstn) then
begin
lvd:=p^.left^.valued;
rvd:=p^.right^.valued;
case p^.treetype of
addn:
t:=genrealconstnode(lvd+rvd);
subn:
t:=genrealconstnode(lvd-rvd);
muln:
t:=genrealconstnode(lvd*rvd);
caretn:
t:=genrealconstnode(exp(ln(lvd)*rvd));
slashn:
t:=genrealconstnode(lvd/rvd);
ltn:
t:=genordinalconstnode(ord(lvd<rvd),booldef);
lten:
t:=genordinalconstnode(ord(lvd<=rvd),booldef);
gtn:
t:=genordinalconstnode(ord(lvd>rvd),booldef);
gten:
t:=genordinalconstnode(ord(lvd>=rvd),booldef);
equaln:
t:=genordinalconstnode(ord(lvd=rvd),booldef);
unequaln:
t:=genordinalconstnode(ord(lvd<>rvd),booldef);
else
Message(sym_e_type_mismatch);
end;
disposetree(p);
p:=t;
dispose(s1);
dispose(s2);
firstpass(p);
exit;
end;
concatstrings:=false;
if (lt=ordconstn) and (rt=ordconstn) and
(p^.left^.resulttype^.deftype=orddef) and
(porddef(p^.left^.resulttype)^.typ=uchar) and
(p^.right^.resulttype^.deftype=orddef) and
(porddef(p^.right^.resulttype)^.typ=uchar) then
begin
s1^:=char(byte(p^.left^.value));
s2^:=char(byte(p^.right^.value));
concatstrings:=true;
end
else if (lt=stringconstn) and (rt=ordconstn) and
(p^.right^.resulttype^.deftype=orddef) and
(porddef(p^.right^.resulttype)^.typ=uchar) then
begin
s1^:=Pstring(p^.left^.value)^;
s2^:=char(byte(p^.right^.value));
concatstrings:=true;
end
else if (lt=ordconstn) and (rt=stringconstn) and
(p^.left^.resulttype^.deftype=orddef) and
(porddef(p^.left^.resulttype)^.typ=uchar) then
begin
s1^:=char(byte(p^.left^.value));
s2^:=pstring(p^.right^.value)^;
concatstrings:=true;
end
else if (lt=stringconstn) and (rt=stringconstn) then
begin
s1^:=pstring(p^.left^.value)^;
s2^:=pstring(p^.right^.value)^;
concatstrings:=true;
end;
if concatstrings then
begin
case p^.treetype of
addn : t:=genstringconstnode(s1^+s2^);
ltn : t:=genordinalconstnode(byte(s1^<s2^),booldef);
lten : t:=genordinalconstnode(byte(s1^<=s2^),booldef);
gtn : t:=genordinalconstnode(byte(s1^>s2^),booldef);
gten : t:=genordinalconstnode(byte(s1^>=s2^),booldef);
equaln : t:=genordinalconstnode(byte(s1^=s2^),booldef);
unequaln : t:=genordinalconstnode(byte(s1^<>s2^),booldef);
end;
dispose(s1);
dispose(s2);
disposetree(p);
p:=t;
exit;
end;
rd:=p^.right^.resulttype;
ld:=p^.left^.resulttype;
dispose(s1);
dispose(s2);
{ we can set this globally but it not allways true }
{ procinfo.flags:=procinfo.flags or pi_do_call; }
{ if both are boolean: }
if ((ld^.deftype=orddef) and
(porddef(ld)^.typ=bool8bit)) and
((rd^.deftype=orddef) and
(porddef(rd)^.typ=bool8bit)) then
begin
if (p^.treetype=andn) or (p^.treetype=orn) then
begin
calcregisters(p,0,0,0);
p^.location.loc:=LOC_JUMP;
end
else if p^.treetype in [unequaln,equaln,xorn] then
begin
{ I'am not very content with this solution, but it's
a working hack (FK) }
p^.left:=gentypeconvnode(p^.left,u8bitdef);
p^.right:=gentypeconvnode(p^.right,u8bitdef);
p^.left^.convtyp:=tc_bool_2_u8bit;
p^.left^.explizit:=true;
firstpass(p^.left);
p^.left^.resulttype:=booldef;
p^.right^.convtyp:=tc_bool_2_u8bit;
p^.right^.explizit:=true;
firstpass(p^.right);
p^.right^.resulttype:=booldef;
calcregisters(p,1,0,0);
{ is done commonly for all data types
p^.location.loc:=LOC_FLAGS;
p^.resulttype:=booldef;
}
end
else Message(sym_e_type_mismatch);
end
{ wenn beides vom Char dann keine Konvertiereung einf<6E>gen }
{ h<>chstens es handelt sich um einen +-Operator }
else if ((rd^.deftype=orddef) and (porddef(rd)^.typ=uchar)) and
((ld^.deftype=orddef) and (porddef(ld)^.typ=uchar)) then
begin
if p^.treetype=addn then
begin
p^.left:=gentypeconvnode(p^.left,cstringdef);
firstpass(p^.left);
p^.right:=gentypeconvnode(p^.right,cstringdef);
firstpass(p^.right);
{ here we call STRCOPY }
procinfo.flags:=procinfo.flags or pi_do_call;
calcregisters(p,0,0,0);
p^.location.loc:=LOC_MEM;
end
else
calcregisters(p,1,0,0);
end
{ if string and character, then conver the character to a string }
else if ((rd^.deftype=stringdef) and
((ld^.deftype=orddef) and (porddef(ld)^.typ=uchar))) or
((ld^.deftype=stringdef) and
((rd^.deftype=orddef) and (porddef(rd)^.typ=uchar))) then
begin
if ((ld^.deftype=orddef) and (porddef(ld)^.typ=uchar)) then
p^.left:=gentypeconvnode(p^.left,cstringdef)
else
p^.right:=gentypeconvnode(p^.right,cstringdef);
firstpass(p^.left);
firstpass(p^.right);
{ here we call STRCONCAT or STRCMP }
procinfo.flags:=procinfo.flags or pi_do_call;
calcregisters(p,0,0,0);
p^.location.loc:=LOC_MEM;
end
else
if ((rd^.deftype=setdef) and (ld^.deftype=setdef)) then
begin
case p^.treetype of
subn,symdifn,addn,muln,equaln,unequaln : ;
else Message(sym_e_type_mismatch);
end;
if not(is_equal(rd,ld)) then
Message(sym_e_set_element_are_not_comp);
firstpass(p^.left);
firstpass(p^.right);
{ do constant evalution }
{ set constructor ? }
if (p^.right^.treetype=setconstrn) and
(p^.left^.treetype=setconstrn) and
{ and no variables ? }
(p^.right^.left=nil) and
(p^.left^.left=nil) then
begin
new(resultset);
case p^.treetype of
addn : begin
for i:=0 to 31 do
resultset^[i]:=
p^.right^.constset^[i] or p^.left^.constset^[i];
t:=gensetconstruktnode(resultset,psetdef(ld));
end;
muln : begin
for i:=0 to 31 do
resultset^[i]:=
p^.right^.constset^[i] and p^.left^.constset^[i];
t:=gensetconstruktnode(resultset,psetdef(ld));
end;
subn : begin
for i:=0 to 31 do
resultset^[i]:=
p^.left^.constset^[i] and not(p^.right^.constset^[i]);
t:=gensetconstruktnode(resultset,psetdef(ld));
end;
symdifn : begin
for i:=0 to 31 do
resultset^[i]:=
p^.left^.constset^[i] xor p^.right^.constset^[i];
t:=gensetconstruktnode(resultset,psetdef(ld));
end;
unequaln : begin
b:=true;
for i:=0 to 31 do
if p^.right^.constset^[i]=p^.left^.constset^[i] then
begin
b:=false;
break;
end;
t:=genordinalconstnode(ord(b),booldef);
end;
equaln : begin
b:=true;
for i:=0 to 31 do
if p^.right^.constset^[i]<>p^.left^.constset^[i] then
begin
b:=false;
break;
end;
t:=genordinalconstnode(ord(b),booldef);
end;
end;
dispose(resultset);
disposetree(p);
p:=t;
firstpass(p);
exit;
end
else if psetdef(rd)^.settype=smallset then
begin
calcregisters(p,1,0,0);
p^.location.loc:=LOC_REGISTER;
end
else
begin
calcregisters(p,0,0,0);
{ here we call SET... }
procinfo.flags:=procinfo.flags or pi_do_call;
p^.location.loc:=LOC_MEM;
end;
end
else
if ((rd^.deftype=stringdef) and (ld^.deftype=stringdef)) then
{ here we call STR... }
procinfo.flags:=procinfo.flags or pi_do_call
{ if there is a real float, convert both to float 80 bit }
else
if ((rd^.deftype=floatdef) and (pfloatdef(rd)^.typ<>f32bit)) or
((ld^.deftype=floatdef) and (pfloatdef(ld)^.typ<>f32bit)) then
begin
p^.right:=gentypeconvnode(p^.right,c64floatdef);
p^.left:=gentypeconvnode(p^.left,c64floatdef);
firstpass(p^.left);
firstpass(p^.right);
calcregisters(p,1,1,0);
p^.location.loc:=LOC_FPU;
end
else
{ if there is one fix comma number, convert both to 32 bit fixcomma }
if ((rd^.deftype=floatdef) and (pfloatdef(rd)^.typ=f32bit)) or
((ld^.deftype=floatdef) and (pfloatdef(ld)^.typ=f32bit)) then
begin
if not(porddef(rd)^.typ in [u8bit,s8bit,u16bit,
s16bit,s32bit]) or (p^.treetype<>muln) then
p^.right:=gentypeconvnode(p^.right,s32fixeddef);
if not(porddef(rd)^.typ in [u8bit,s8bit,u16bit,
s16bit,s32bit]) or (p^.treetype<>muln) then
p^.left:=gentypeconvnode(p^.left,s32fixeddef);
firstpass(p^.left);
firstpass(p^.right);
calcregisters(p,1,0,0);
p^.location.loc:=LOC_REGISTER;
end
{ pointer comperation and subtraction }
else if (rd^.deftype=pointerdef) and (ld^.deftype=pointerdef) then
begin
p^.location.loc:=LOC_REGISTER;
p^.right:=gentypeconvnode(p^.right,ld);
firstpass(p^.right);
calcregisters(p,1,0,0);
case p^.treetype of
equaln,unequaln : ;
ltn,lten,gtn,gten:
begin
if not(cs_extsyntax in aktswitches) then
Message(sym_e_type_mismatch);
end;
subn:
begin
if not(cs_extsyntax in aktswitches) then
Message(sym_e_type_mismatch);
p^.resulttype:=s32bitdef;
exit;
end;
else Message(sym_e_type_mismatch);
end;
end
else if (rd^.deftype=objectdef) and (ld^.deftype=objectdef) and
pobjectdef(rd)^.isclass and pobjectdef(ld)^.isclass then
begin
p^.location.loc:=LOC_REGISTER;
if pobjectdef(rd)^.isrelated(pobjectdef(ld)) then
p^.right:=gentypeconvnode(p^.right,ld)
else
p^.left:=gentypeconvnode(p^.left,rd);
firstpass(p^.right);
firstpass(p^.left);
calcregisters(p,1,0,0);
case p^.treetype of
equaln,unequaln : ;
else Message(sym_e_type_mismatch);
end;
end
else if (rd^.deftype=classrefdef) and (ld^.deftype=classrefdef) then
begin
p^.location.loc:=LOC_REGISTER;
if pobjectdef(pclassrefdef(rd)^.definition)^.isrelated(pobjectdef(
pclassrefdef(ld)^.definition)) then
p^.right:=gentypeconvnode(p^.right,ld)
else
p^.left:=gentypeconvnode(p^.left,rd);
firstpass(p^.right);
firstpass(p^.left);
calcregisters(p,1,0,0);
case p^.treetype of
equaln,unequaln : ;
else Message(sym_e_type_mismatch);
end;
end
{ allows comperasion with nil pointer }
else if (rd^.deftype=objectdef) and
pobjectdef(rd)^.isclass then
begin
p^.location.loc:=LOC_REGISTER;
p^.left:=gentypeconvnode(p^.left,rd);
firstpass(p^.left);
calcregisters(p,1,0,0);
case p^.treetype of
equaln,unequaln : ;
else Message(sym_e_type_mismatch);
end;
end
else if (ld^.deftype=objectdef) and
pobjectdef(ld)^.isclass then
begin
p^.location.loc:=LOC_REGISTER;
p^.right:=gentypeconvnode(p^.right,ld);
firstpass(p^.right);
calcregisters(p,1,0,0);
case p^.treetype of
equaln,unequaln : ;
else Message(sym_e_type_mismatch);
end;
end
else if (rd^.deftype=classrefdef) then
begin
p^.left:=gentypeconvnode(p^.left,rd);
firstpass(p^.left);
calcregisters(p,1,0,0);
case p^.treetype of
equaln,unequaln : ;
else Message(sym_e_type_mismatch);
end;
end
else if (ld^.deftype=classrefdef) then
begin
p^.right:=gentypeconvnode(p^.right,ld);
firstpass(p^.right);
calcregisters(p,1,0,0);
case p^.treetype of
equaln,unequaln : ;
else Message(sym_e_type_mismatch);
end;
end
else if (rd^.deftype=pointerdef) then
begin
p^.location.loc:=LOC_REGISTER;
p^.left:=gentypeconvnode(p^.left,s32bitdef);
firstpass(p^.left);
calcregisters(p,1,0,0);
if p^.treetype=addn then
begin
if not(cs_extsyntax in aktswitches) then
Message(sym_e_type_mismatch);
end
else Message(sym_e_type_mismatch);
end
else if (ld^.deftype=pointerdef) then
begin
p^.location.loc:=LOC_REGISTER;
p^.right:=gentypeconvnode(p^.right,s32bitdef);
firstpass(p^.right);
calcregisters(p,1,0,0);
case p^.treetype of
addn,subn : if not(cs_extsyntax in aktswitches) then
Message(sym_e_type_mismatch);
else Message(sym_e_type_mismatch);
end;
end
else if (rd^.deftype=procvardef) and (ld^.deftype=procvardef) and
is_equal(rd,ld) then
begin
calcregisters(p,1,0,0);
p^.location.loc:=LOC_REGISTER;
case p^.treetype of
equaln,unequaln : ;
else Message(sym_e_type_mismatch);
end;
end
else if (ld^.deftype=enumdef) and (rd^.deftype=enumdef)
and (is_equal(ld,rd)) then
begin
calcregisters(p,1,0,0);
case p^.treetype of
equaln,unequaln,
ltn,lten,gtn,gten : ;
else Message(sym_e_type_mismatch);
end;
end
{$ifdef SUPPORT_MMX}
else if (cs_mmx in aktswitches) and is_mmx_able_array(ld)
and is_mmx_able_array(rd) and is_equal(ld,rd) then
begin
firstpass(p^.right);
firstpass(p^.left);
case p^.treetype of
addn,subn,xorn,orn,andn:
;
{ mul is a little bit restricted }
muln:
if not(mmx_type(p^.left^.resulttype) in
[mmxu16bit,mmxs16bit,mmxfixed16]) then
Message(sym_e_type_mismatch);
else
Message(sym_e_type_mismatch);
end;
p^.location.loc:=LOC_MMXREGISTER;
calcregisters(p,0,0,1);
end
{$endif SUPPORT_MMX}
{ the general solution is to convert to 32 bit int }
else
begin
{ but an int/int gives real/real! }
if p^.treetype=slashn then
begin
Message(parser_w_use_int_div_int_op);
p^.right:=gentypeconvnode(p^.right,c64floatdef);
p^.left:=gentypeconvnode(p^.left,c64floatdef);
firstpass(p^.left);
firstpass(p^.right);
{ maybe we need an integer register to save }
{ a reference }
if ((p^.left^.location.loc<>LOC_FPU) or
(p^.right^.location.loc<>LOC_FPU)) and
(p^.left^.registers32=p^.right^.registers32) then
calcregisters(p,1,1,0)
else
calcregisters(p,0,1,0);
p^.location.loc:=LOC_FPU;
end
else
begin
p^.right:=gentypeconvnode(p^.right,s32bitdef);
p^.left:=gentypeconvnode(p^.left,s32bitdef);
firstpass(p^.left);
firstpass(p^.right);
calcregisters(p,1,0,0);
p^.location.loc:=LOC_REGISTER;
end;
end;
if codegenerror then
exit;
{ determines result type for comparions }
case p^.treetype of
ltn,lten,gtn,gten,equaln,unequaln:
begin
p^.resulttype:=booldef;
p^.location.loc:=LOC_FLAGS;
end;
addn:
begin
{ the result of a string addition is a string of length 255 }
if (p^.left^.resulttype^.deftype=stringdef) or
(p^.right^.resulttype^.deftype=stringdef) then
p^.resulttype:=cstringdef
else
p^.resulttype:=p^.left^.resulttype;
end;
else p^.resulttype:=p^.left^.resulttype;
end;
end;
procedure firstmoddiv(var p : ptree);
var
t : ptree;
{power : longint; }
begin
firstpass(p^.left);
firstpass(p^.right);
if codegenerror then
exit;
if is_constintnode(p^.left) and is_constintnode(p^.right) then
begin
case p^.treetype of
modn : t:=genordinalconstnode(p^.left^.value mod p^.right^.value,s32bitdef);
divn : t:=genordinalconstnode(p^.left^.value div p^.right^.value,s32bitdef);
end;
disposetree(p);
p:=t;
exit;
end;
{ !!!!!! u32bit }
p^.right:=gentypeconvnode(p^.right,s32bitdef);
p^.left:=gentypeconvnode(p^.left,s32bitdef);
firstpass(p^.left);
firstpass(p^.right);
if codegenerror then
exit;
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
{$endif SUPPORT_MMX}
if p^.registers32<2 then p^.registers32:=2;
p^.resulttype:=s32bitdef;
p^.location.loc:=LOC_REGISTER;
end;
procedure firstshlshr(var p : ptree);
var
t : ptree;
begin
firstpass(p^.left);
firstpass(p^.right);
if codegenerror then
exit;
if is_constintnode(p^.left) and is_constintnode(p^.right) then
begin
case p^.treetype of
shrn : t:=genordinalconstnode(p^.left^.value shr p^.right^.value,s32bitdef);
shln : t:=genordinalconstnode(p^.left^.value shl p^.right^.value,s32bitdef);
end;
disposetree(p);
p:=t;
exit;
end;
p^.right:=gentypeconvnode(p^.right,s32bitdef);
p^.left:=gentypeconvnode(p^.left,s32bitdef);
firstpass(p^.left);
firstpass(p^.right);
if codegenerror then
exit;
calcregisters(p,2,0,0);
{
p^.registers32:=p^.left^.registers32;
if p^.registers32<p^.right^.registers32 then
p^.registers32:=p^.right^.registers32;
if p^.registers32<1 then p^.registers32:=1;
}
p^.resulttype:=s32bitdef;
p^.location.loc:=LOC_REGISTER;
end;
procedure firstrealconst(var p : ptree);
begin
p^.location.loc:=LOC_MEM;
end;
procedure firstfixconst(var p : ptree);
begin
p^.location.loc:=LOC_MEM;
end;
procedure firstordconst(var p : ptree);
begin
p^.location.loc:=LOC_MEM;
end;
procedure firstniln(var p : ptree);
begin
p^.resulttype:=voidpointerdef;
p^.location.loc:=LOC_MEM;
end;
procedure firststringconst(var p : ptree);
begin
{$ifdef GDB}
{why this !!! lost of dummy type definitions
one per const string !!!
p^.resulttype:=new(pstringdef,init(length(p^.values^)));}
p^.resulttype:=cstringdef;
{$Else GDB}
p^.resulttype:=new(pstringdef,init(length(p^.values^)));
{$endif * GDB *}
p^.location.loc:=LOC_MEM;
end;
procedure firstumminus(var p : ptree);
var
t : ptree;
minusdef : pprocdef;
begin
firstpass(p^.left);
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
p^.resulttype:=p^.left^.resulttype;
if codegenerror then
exit;
if is_constintnode(p^.left) then
begin
t:=genordinalconstnode(-p^.left^.value,s32bitdef);
disposetree(p);
firstpass(t);
p:=t;
exit;
end;
{ nasm can not cope with negativ reals !! }
if is_constrealnode(p^.left)
{$ifdef i386}
and (current_module^.output_format<>of_nasm)
{$endif}
then
begin
t:=genrealconstnode(-p^.left^.valued);
disposetree(p);
firstpass(t);
p:=t;
exit;
end;
if (p^.left^.resulttype^.deftype=floatdef) then
begin
if pfloatdef(p^.left^.resulttype)^.typ=f32bit then
begin
if (p^.left^.location.loc<>LOC_REGISTER) and
(p^.registers32<1) then
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end
else
p^.location.loc:=LOC_FPU;
end
{$ifdef SUPPORT_MMX}
else if (cs_mmx in aktswitches) and
is_mmx_able_array(p^.left^.resulttype) then
begin
if (p^.left^.location.loc<>LOC_MMXREGISTER) and
(p^.registersmmx<1) then
p^.registersmmx:=1;
{ if saturation is on, p^.left^.resulttype isn't
"mmx able" (FK)
if (cs_mmx_saturation in aktswitches^) and
(porddef(parraydef(p^.resulttype)^.definition)^.typ in
[s32bit,u32bit]) then
Message(sym_e_type_mismatch);
}
end
{$endif SUPPORT_MMX}
else if (p^.left^.resulttype^.deftype=orddef) then
begin
p^.left:=gentypeconvnode(p^.left,s32bitdef);
firstpass(p^.left);
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
p^.registers32:=p^.left^.registers32;
if codegenerror then
exit;
if (p^.left^.location.loc<>LOC_REGISTER) and
(p^.registers32<1) then
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
p^.resulttype:=p^.left^.resulttype;
end
else
begin
if assigned(overloaded_operators[minus]) then
minusdef:=overloaded_operators[minus]^.definition
else
minusdef:=nil;
while assigned(minusdef) do
begin
if (minusdef^.para1^.data=p^.left^.resulttype) and
(minusdef^.para1^.next=nil) then
begin
t:=gencallnode(overloaded_operators[minus],nil);
t^.left:=gencallparanode(p^.left,nil);
putnode(p);
p:=t;
firstpass(p);
exit;
end;
minusdef:=minusdef^.nextoverloaded;
end;
Message(sym_e_type_mismatch);
end;
end;
procedure firstaddr(var p : ptree);
var
hp : ptree;
hp2 : pdefcoll;
store_valid : boolean;
begin
make_not_regable(p^.left);
if not(assigned(p^.resulttype)) then
begin
if p^.left^.treetype=calln then
begin
hp:=genloadnode(pvarsym(p^.left^.symtableprocentry),p^.left^.symtableproc);
{ result is a procedure variable }
{ No, to be TP compatible, you must return a pointer to
the procedure that is stored in the procvar.}
if not(cs_tp_compatible in aktswitches) then
begin
p^.resulttype:=new(pprocvardef,init);
pprocvardef(p^.resulttype)^.options:=
p^.left^.symtableprocentry^.definition^.options;
pprocvardef(p^.resulttype)^.retdef:=
p^.left^.symtableprocentry^.definition^.retdef;
hp2:=p^.left^.symtableprocentry^.definition^.para1;
while assigned(hp2) do
begin
pprocvardef(p^.resulttype)^.concatdef(hp2^.data,hp2^.paratyp);
hp2:=hp2^.next;
end;
end
else
p^.resulttype:=voidpointerdef;
disposetree(p^.left);
p^.left:=hp;
end
else
begin
if not(cs_typed_addresses in aktswitches) then
p^.resulttype:=voidpointerdef
else p^.resulttype:=new(ppointerdef,init(p^.left^.resulttype));
end;
end;
store_valid:=must_be_valid;
must_be_valid:=false;
firstpass(p^.left);
must_be_valid:=store_valid;
if codegenerror then
exit;
{ we should allow loc_mem for @string }
if (p^.left^.location.loc<>LOC_REFERENCE) and
(p^.left^.location.loc<>LOC_MEM) then
Message(cg_e_illegal_expression);
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
if p^.registers32<1 then
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end;
procedure firstdoubleaddr(var p : ptree);
var
hp : ptree;
hp2 : pdefcoll;
begin
make_not_regable(p^.left);
firstpass(p^.left);
if p^.resulttype=nil then
p^.resulttype:=voidpointerdef;
if (p^.left^.resulttype^.deftype)<>procvardef then
Message(cg_e_illegal_expression);
if codegenerror then
exit;
if (p^.left^.location.loc<>LOC_REFERENCE) then
Message(cg_e_illegal_expression);
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
if p^.registers32<1 then
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end;
procedure firstnot(var p : ptree);
var
t : ptree;
begin
firstpass(p^.left);
if codegenerror then
exit;
if (p^.left^.treetype=ordconstn) then
begin
t:=genordinalconstnode(not(p^.left^.value),p^.left^.resulttype);
disposetree(p);
p:=t;
exit;
end;
p^.resulttype:=p^.left^.resulttype;
p^.location.loc:=p^.left^.location.loc;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
if is_equal(p^.resulttype,booldef) then
begin
p^.registers32:=p^.left^.registers32;
if ((p^.location.loc=LOC_REFERENCE) or
(p^.location.loc=LOC_CREGISTER)) and
(p^.registers32<1) then
p^.registers32:=1;
end
else
{$ifdef SUPPORT_MMX}
if (cs_mmx in aktswitches) and
is_mmx_able_array(p^.left^.resulttype) then
begin
if (p^.left^.location.loc<>LOC_MMXREGISTER) and
(p^.registersmmx<1) then
p^.registersmmx:=1;
end
else
{$endif SUPPORT_MMX}
begin
p^.left:=gentypeconvnode(p^.left,s32bitdef);
firstpass(p^.left);
if codegenerror then
exit;
p^.resulttype:=p^.left^.resulttype;
p^.registers32:=p^.left^.registers32;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
if (p^.left^.location.loc<>LOC_REGISTER) and
(p^.registers32<1) then
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end;
p^.registersfpu:=p^.left^.registersfpu;
end;
procedure firstnothing(var p : ptree);
begin
end;
procedure firstassignment(var p : ptree);
var
store_valid : boolean;
hp : ptree;
begin
store_valid:=must_be_valid;
must_be_valid:=false;
firstpass(p^.left);
{ assignements to open arrays aren't allowed }
if is_open_array(p^.left^.resulttype) then
Message(sym_e_type_mismatch);
{$ifdef dummyi386}
if ((p^.right^.treetype=addn) or (p^.right^.treetype=subn)) and
equal_trees(p^.left,p^.right^.left) and
(ret_in_acc(p^.left^.resulttype)) and
(not cs_rangechecking in aktswitches^) then
begin
disposetree(p^.right^.left);
hp:=p^.right;
p^.right:=p^.right^.right;
if hp^.treetype=addn then
p^.assigntyp:=at_plus
else
p^.assigntyp:=at_minus;
putnode(hp);
end;
if p^.assigntyp<>at_normal then
begin
{ for fpu type there is no faster way }
if is_fpu(p^.left^.resulttype) then
case p^.assigntyp of
at_plus : p^.right:=gennode(addn,getcopy(p^.left),p^.right);
at_minus : p^.right:=gennode(subn,getcopy(p^.left),p^.right);
at_star : p^.right:=gennode(muln,getcopy(p^.left),p^.right);
at_slash : p^.right:=gennode(slashn,getcopy(p^.left),p^.right);
end;
end;
{$endif i386}
must_be_valid:=true;
firstpass(p^.right);
must_be_valid:=store_valid;
if codegenerror then
exit;
{ some string functions don't need conversion, so treat them separatly }
if p^.left^.resulttype^.deftype=stringdef then
begin
if not (p^.right^.resulttype^.deftype in [stringdef,orddef]) then
begin
p^.right:=gentypeconvnode(p^.right,p^.left^.resulttype);
firstpass(p^.right);
if codegenerror then
exit;
end;
{ we call STRCOPY }
procinfo.flags:=procinfo.flags or pi_do_call;
end
else
begin
if (p^.right^.treetype=realconstn) then
begin
if p^.left^.resulttype^.deftype=floatdef then
begin
case pfloatdef(p^.left^.resulttype)^.typ of
s32real : p^.right^.realtyp:=ait_real_32bit;
s64real : p^.right^.realtyp:=ait_real_64bit;
s80real : p^.right^.realtyp:=ait_real_extended;
{ what about f32bit and s64bit }
else
begin
p^.right:=gentypeconvnode(p^.right,p^.left^.resulttype);
{ nochmal firstpass wegen der Typkonvertierung aufrufen }
firstpass(p^.right);
if codegenerror then
exit;
end;
end;
end;
end
else
begin
p^.right:=gentypeconvnode(p^.right,p^.left^.resulttype);
firstpass(p^.right);
if codegenerror then
exit;
end;
end;
p^.resulttype:=voiddef;
{
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
}
p^.registers32:=p^.left^.registers32+p^.right^.registers32;
p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
{$endif SUPPORT_MMX}
end;
procedure firstlr(var p : ptree);
begin
firstpass(p^.left);
firstpass(p^.right);
end;
procedure firstderef(var p : ptree);
begin
firstpass(p^.left);
if codegenerror then
exit;
p^.registers32:=max(p^.left^.registers32,1);
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
if p^.left^.resulttype^.deftype<>pointerdef then
Message(cg_e_invalid_qualifier);
p^.resulttype:=ppointerdef(p^.left^.resulttype)^.definition;
p^.location.loc:=LOC_REFERENCE;
end;
procedure firstrange(var p : ptree);
var
ct : tconverttype;
begin
firstpass(p^.left);
firstpass(p^.right);
if codegenerror then
exit;
{ allow only ordinal constants }
if not((p^.left^.treetype=ordconstn) and
(p^.right^.treetype=ordconstn)) then
Message(cg_e_illegal_expression);
{ upper limit must be greater or equalt than lower limit }
{ not if u32bit }
if (p^.left^.value>p^.right^.value) and
(( p^.left^.value<0) or (p^.right^.value>=0)) then
Message(cg_e_upper_lower_than_lower);
{ both types must be compatible }
if not(isconvertable(p^.left^.resulttype,p^.right^.resulttype,
ct,ordconstn)) and
not(is_equal(p^.left^.resulttype,p^.right^.resulttype)) then
Message(sym_e_type_mismatch);
end;
procedure firstvecn(var p : ptree);
var
harr : pdef;
ct : tconverttype;
begin
firstpass(p^.left);
firstpass(p^.right);
if codegenerror then
exit;
{ range check only for arrays }
if (p^.left^.resulttype^.deftype=arraydef) then
begin
if not(isconvertable(p^.right^.resulttype,
parraydef(p^.left^.resulttype)^.rangedef,
ct,ordconstn)) and
not(is_equal(p^.right^.resulttype,
parraydef(p^.left^.resulttype)^.rangedef)) then
Message(sym_e_type_mismatch);
end;
{ Never convert a boolean or a char !}
{ maybe type conversion }
if (p^.right^.resulttype^.deftype<>enumdef) and
not ((p^.right^.resulttype^.deftype=orddef) and
(Porddef(p^.right^.resulttype)^.typ in [bool8bit,uchar])) then
begin
p^.right:=gentypeconvnode(p^.right,s32bitdef);
{ once more firstpass }
{?? It's better to only firstpass when the tree has
changed, isn't it ?}
firstpass(p^.right);
end;
if codegenerror then
exit;
{ determine return type }
if p^.left^.resulttype^.deftype=arraydef then
p^.resulttype:=parraydef(p^.left^.resulttype)^.definition
else if (p^.left^.resulttype^.deftype=pointerdef) then
begin
{ convert pointer to array }
harr:=new(parraydef,init(0,$7fffffff,s32bitdef));
parraydef(harr)^.definition:=ppointerdef(p^.left^.resulttype)^.definition;
p^.left:=gentypeconvnode(p^.left,harr);
firstpass(p^.left);
if codegenerror then
exit;
p^.resulttype:=parraydef(harr)^.definition
end
else
{ indexed access to arrays }
p^.resulttype:=cchardef;
{ the register calculation is easy if a const index is used }
if p^.right^.treetype=ordconstn then
p^.registers32:=p^.left^.registers32
else
begin
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
{ not correct, but what works better ? }
if p^.left^.registers32>0 then
p^.registers32:=max(p^.registers32,2)
else
{ min. one register }
p^.registers32:=max(p^.registers32,1);
end;
p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
{$endif SUPPORT_MMX}
p^.location.loc:=p^.left^.location.loc;
end;
type
tfirstconvproc = procedure(var p : ptree);
procedure first_bigger_smaller(var p : ptree);
begin
if (p^.left^.location.loc<>LOC_REGISTER) and (p^.registers32=0) then
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end;
procedure first_cstring_charpointer(var p : ptree);
begin
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end;
procedure first_string_chararray(var p : ptree);
begin
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end;
procedure first_string_string(var p : ptree);
var l : longint;
begin
if p^.left^.treetype=stringconstn then
l:=length(pstring(p^.left^.value)^)
else
l:=pstringdef(p^.left^.resulttype)^.len;
if l<>parraydef(p^.resulttype)^.highrange-parraydef(p^.resulttype)^.lowrange+1 then
Message(sym_e_type_mismatch);
end;
procedure first_char_to_string(var p : ptree);
var
hp : ptree;
begin
if p^.left^.treetype=ordconstn then
begin
hp:=genstringconstnode(chr(p^.left^.value));
firstpass(hp);
disposetree(p);
p:=hp;
end
else
p^.location.loc:=LOC_MEM;
end;
procedure first_nothing(var p : ptree);
begin
p^.location.loc:=LOC_MEM;
end;
procedure first_array_to_pointer(var p : ptree);
begin
if p^.registers32<1 then
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end;
procedure first_int_real(var p : ptree);
var t : ptree;
begin
if p^.left^.treetype=ordconstn then
begin
{ convert constants direct }
{ not because of type conversion }
t:=genrealconstnode(p^.left^.value);
firstpass(t);
{ the type can be something else than s64real !!}
t:=gentypeconvnode(t,p^.resulttype);
firstpass(t);
disposetree(p);
p:=t;
exit;
end
else
begin
if p^.registersfpu<1 then
p^.registersfpu:=1;
p^.location.loc:=LOC_FPU;
end;
end;
procedure first_int_fix(var p : ptree);
begin
if p^.left^.treetype=ordconstn then
begin
{ convert constants direct }
p^.treetype:=fixconstn;
p^.valuef:=p^.left^.value shl 16;
p^.disposetyp:=dt_nothing;
disposetree(p^.left);
p^.location.loc:=LOC_MEM;
end
else
begin
if p^.registers32<1 then
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end;
end;
procedure first_real_fix(var p : ptree);
begin
if p^.left^.treetype=realconstn then
begin
{ convert constants direct }
p^.treetype:=fixconstn;
p^.valuef:=round(p^.left^.valued*65536);
p^.disposetyp:=dt_nothing;
disposetree(p^.left);
p^.location.loc:=LOC_MEM;
end
else
begin
{ at least one fpu and int register needed }
if p^.registers32<1 then
p^.registers32:=1;
if p^.registersfpu<1 then
p^.registersfpu:=1;
p^.location.loc:=LOC_REGISTER;
end;
end;
procedure first_fix_real(var p : ptree);
begin
if p^.left^.treetype=fixconstn then
begin
{ convert constants direct }
p^.treetype:=realconstn;
p^.valued:=round(p^.left^.valuef/65536.0);
p^.disposetyp:=dt_nothing;
disposetree(p^.left);
p^.location.loc:=LOC_MEM;
end
else
begin
if p^.registersfpu<1 then
p^.registersfpu:=1;
p^.location.loc:=LOC_FPU;
end;
end;
procedure first_real_real(var p : ptree);
begin
if p^.registersfpu<1 then
p^.registersfpu:=1;
p^.location.loc:=LOC_FPU;
end;
procedure first_pointer_to_array(var p : ptree);
begin
if p^.registers32<1 then
p^.registers32:=1;
p^.location.loc:=LOC_REFERENCE;
end;
procedure first_chararray_string(var p : ptree);
begin
{ the only important information is the location of the }
{ result }
{ other stuff is done by firsttypeconv }
p^.location.loc:=LOC_MEM;
end;
procedure first_cchar_charpointer(var p : ptree);
begin
p^.left:=gentypeconvnode(p^.left,cstringdef);
{ convert constant char to constant string }
firstpass(p^.left);
{ evalute tree }
firstpass(p);
end;
procedure first_locmem(var p : ptree);
begin
p^.location.loc:=LOC_MEM;
end;
procedure first_bool_byte(var p : ptree);
begin
p^.location.loc:=LOC_REGISTER;
{ Florian I think this is overestimated
but I still do not really understand how to get this right (PM) }
{ Hmmm, I think we need only one reg to return the result of }
{ this node => so
if p^.registers32<1 then
p^.registers32:=1;
should work (FK)
}
p^.registers32:=p^.left^.registers32+1;
end;
procedure first_proc_to_procvar(var p : ptree);
var
hp : ptree;
hp2 : pdefcoll;
begin
firstpass(p^.left);
if codegenerror then
exit;
if (p^.left^.location.loc<>LOC_REFERENCE) then
Message(cg_e_illegal_expression);
p^.registers32:=p^.left^.registers32;
if p^.registers32<1 then
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end;
function is_procsym_load(p:Ptree):boolean;
begin
is_procsym_load:=((p^.treetype=loadn) and (p^.symtableentry^.typ=procsym)) or
((p^.treetype=addrn) and (p^.left^.treetype=loadn)
and (p^.left^.symtableentry^.typ=procsym)) ;
end;
{ change a proc call to a procload for assignment to a procvar }
{ this can only happen for proc/function without arguments }
function is_procsym_call(p:Ptree):boolean;
begin
is_procsym_call:=(p^.treetype=calln) and (p^.left=nil) and
(((p^.symtableprocentry^.typ=procsym) and (p^.right=nil)) or
((p^.right<>nil) and (p^.right^.symtableprocentry^.typ=varsym)));
end;
{***}
function is_assignment_overloaded(from_def,to_def : pdef) : boolean;
var
passproc : pprocdef;
begin
is_assignment_overloaded:=false;
if assigned(overloaded_operators[assignment]) then
passproc:=overloaded_operators[assignment]^.definition
else
passproc:=nil;
while passproc<>nil do
begin
if (passproc^.retdef=to_def) and (passproc^.para1^.data=from_def) then
begin
is_assignment_overloaded:=true;
break;
end;
passproc:=passproc^.nextoverloaded;
end;
end;
{ Attention: do *** no *** recursive call of firstpass }
{ because the child tree is always passed }
procedure firsttypeconv(var p : ptree);
var
hp : ptree;
hp2,hp3:Pdefcoll;
aprocdef : pprocdef;
proctype : tdeftype;
const
firstconvert : array[tc_u8bit_2_s32bit..tc_cchar_charpointer] of
tfirstconvproc = (first_bigger_smaller,first_nothing,first_bigger_smaller,
first_bigger_smaller,first_bigger_smaller,
first_bigger_smaller,first_bigger_smaller,
first_bigger_smaller,first_locmem,
first_cstring_charpointer,first_string_chararray,
first_array_to_pointer,first_pointer_to_array,
first_char_to_string,first_bigger_smaller,
first_bigger_smaller,first_bigger_smaller,
first_bigger_smaller,first_bigger_smaller,
first_bigger_smaller,first_bigger_smaller,
first_bigger_smaller,first_bigger_smaller,
first_bigger_smaller,first_bigger_smaller,
first_bigger_smaller,first_bigger_smaller,
first_bigger_smaller,first_bigger_smaller,
first_int_real,first_real_fix,
first_fix_real,first_int_fix,first_real_real,
first_locmem,first_bool_byte,first_proc_to_procvar,
first_cchar_charpointer);
begin
aprocdef:=nil;
{ if explicite type conversation, then run firstpass }
if p^.explizit then
firstpass(p^.left);
if codegenerror then
exit;
{ remove obsolete type conversions }
if is_equal(p^.left^.resulttype,p^.resulttype) then
begin
hp:=p;
p:=p^.left;
p^.resulttype:=hp^.resulttype;
putnode(hp);
exit;
end;
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif}
set_location(p^.location,p^.left^.location);
if (not(isconvertable(p^.left^.resulttype,p^.resulttype,p^.convtyp,p^.left^.treetype))) then
begin
if is_assignment_overloaded(p^.left^.resulttype,p^.resulttype) then
begin
procinfo.flags:=procinfo.flags or pi_do_call;
hp:=gencallnode(overloaded_operators[assignment],nil);
hp^.left:=gencallparanode(p^.left,nil);
putnode(p);
p:=hp;
firstpass(p);
exit;
end;
{Procedures have a resulttype of voiddef and functions of their
own resulttype. They will therefore always be incompatible with
a procvar. Because isconvertable cannot check for procedures we
use an extra check for them.}
if (cs_tp_compatible in aktswitches) and
((is_procsym_load(p^.left) or is_procsym_call(p^.left)) and
(p^.resulttype^.deftype=procvardef)) then
begin
{ just a test: p^.explizit:=false; }
if is_procsym_call(p^.left) then
begin
if p^.left^.right=nil then
begin
p^.left^.treetype:=loadn;
{ are at same offset so this could be spared, but
it more secure to do it anyway }
p^.left^.symtableentry:=p^.left^.symtableprocentry;
p^.left^.resulttype:=pprocsym(p^.left^.symtableentry)^.definition;
aprocdef:=pprocdef(p^.left^.resulttype);
end
else
begin
p^.left^.right^.treetype:=loadn;
p^.left^.right^.symtableentry:=p^.left^.right^.symtableentry;
P^.left^.right^.resulttype:=pvarsym(p^.left^.symtableentry)^.definition;
hp:=p^.left^.right;
putnode(p^.left);
p^.left:=hp;
{ should we do that ? }
firstpass(p^.left);
if not is_equal(p^.left^.resulttype,p^.resulttype) then
begin
Message(sym_e_type_mismatch);
exit;
end
else
begin
hp:=p;
p:=p^.left;
p^.resulttype:=hp^.resulttype;
putnode(hp);
exit;
end;
end;
end
else
begin
if p^.left^.treetype=addrn then
begin
hp:=p^.left;
p^.left:=p^.left^.left;
putnode(p^.left);
end
else
aprocdef:=pprocsym(p^.left^.symtableentry)^.definition;
end;
p^.convtyp:=tc_proc2procvar;
{ Now check if the procedure we are going to assign to
the procvar, is compatible with the procvar's type.
Did the original procvar support do such a check?
I can't find any.}
{ answer : is_equal works for procvardefs !! }
{ but both must be procvardefs, so we cheet little }
if assigned(aprocdef) then
begin
proctype:=aprocdef^.deftype;
aprocdef^.deftype:=procvardef;
if not is_equal(aprocdef,p^.resulttype) then
begin
aprocdef^.deftype:=proctype;
Message(sym_e_type_mismatch);
end;
aprocdef^.deftype:=proctype;
firstconvert[p^.convtyp](p);
end
else
Message(sym_e_type_mismatch);
exit;
end
else
begin
if p^.explizit then
begin
{ boolean to byte are special because the
location can be different }
if (p^.resulttype^.deftype=orddef) and
(porddef(p^.resulttype)^.typ=u8bit) and
(p^.left^.resulttype^.deftype=orddef) and
(porddef(p^.left^.resulttype)^.typ=bool8bit) then
begin
p^.convtyp:=tc_bool_2_u8bit;
firstconvert[p^.convtyp](p);
exit;
end;
{ normal tc_equal-Konvertierung durchf<68>hren }
p^.convtyp:=tc_equal;
{ wenn Aufz<66>hltyp nach Ordinal konvertiert werden soll }
{ dann Aufz<66>hltyp=s32bit }
if (p^.left^.resulttype^.deftype=enumdef) and
is_ordinal(p^.resulttype) then
begin
if p^.left^.treetype=ordconstn then
begin
hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
disposetree(p);
p:=hp;
exit;
end
else
begin
if not isconvertable(s32bitdef,p^.resulttype,p^.convtyp,ordconstn { nur Dummy} ) then
Message(cg_e_illegal_type_conversion);
end;
end
{ ordinal to enumeration }
else
if (p^.resulttype^.deftype=enumdef) and
is_ordinal(p^.left^.resulttype) then
begin
if p^.left^.treetype=ordconstn then
begin
hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
disposetree(p);
p:=hp;
exit;
end
else
begin
if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn { nur Dummy} ) then
Message(cg_e_illegal_type_conversion);
end;
end
{Are we typecasting an ordconst to a char?}
else
if is_equal(p^.resulttype,cchardef) and
is_ordinal(p^.left^.resulttype) then
begin
if p^.left^.treetype=ordconstn then
begin
hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
disposetree(p);
p:=hp;
exit;
end
else
begin
{ this is wrong because it converts to a 4 byte long var !!
if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn nur Dummy ) then }
if not isconvertable(p^.left^.resulttype,u8bitdef,p^.convtyp,ordconstn { nur Dummy} ) then
Message(cg_e_illegal_type_conversion);
end;
end
{ only if the same size or formal def }
{ why do we allow typecasting of voiddef ?? (PM) }
else
if not(
(p^.left^.resulttype^.deftype=formaldef) or
(p^.left^.resulttype^.size=p^.resulttype^.size) or
(is_equal(p^.left^.resulttype,voiddef) and
(p^.left^.treetype=derefn))
) then
Message(cg_e_illegal_type_conversion);
{ the conversion into a strutured type is only }
{ possible, if the source is no register }
if (p^.resulttype^.deftype in [recorddef,stringdef,arraydef,objectdef]) and
(p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
Message(cg_e_illegal_type_conversion);
end
else
Message(sym_e_type_mismatch);
end
end
else
begin
{ just a test: p^.explizit:=false; }
{ ordinale contants are direct converted }
if (p^.left^.treetype=ordconstn) and is_ordinal(p^.resulttype) then
begin
{ perform range checking }
if not(p^.explizit and (cs_tp_compatible in aktswitches)) then
testrange(p^.resulttype,p^.left^.value);
hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
disposetree(p);
p:=hp;
exit;
end;
if p^.convtyp<>tc_equal then
firstconvert[p^.convtyp](p);
end;
end;
{ *************** subroutine handling **************** }
procedure firstcallparan(var p : ptree;defcoll : pdefcoll);
var store_valid : boolean;
convtyp : tconverttype;
begin
inc(parsing_para_level);
if assigned(p^.right) then
begin
if defcoll=nil then
firstcallparan(p^.right,nil)
else
firstcallparan(p^.right,defcoll^.next);
p^.registers32:=p^.right^.registers32;
p^.registersfpu:=p^.right^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.right^.registersmmx;
{$endif}
end;
if defcoll=nil then
begin
firstpass(p^.left);
if codegenerror then
begin
dec(parsing_para_level);
exit;
end;
p^.resulttype:=p^.left^.resulttype;
end
{ if we know the routine which is called, then the type }
{ conversions are inserted }
else
begin
if count_ref then
begin
store_valid:=must_be_valid;
if (defcoll^.paratyp<>vs_var) then
must_be_valid:=true
else
must_be_valid:=false;
{ here we must add something for the implicit type }
{ conversion from array of char to pchar }
if isconvertable(p^.left^.resulttype,defcoll^.data,convtyp,p^.left^.treetype) then
if convtyp=tc_array_to_pointer then
must_be_valid:=false;
firstpass(p^.left);
must_be_valid:=store_valid;
End;
if not((p^.left^.resulttype^.deftype=stringdef) and
(defcoll^.data^.deftype=stringdef)) and
(defcoll^.data^.deftype<>formaldef) then
begin
if (defcoll^.paratyp=vs_var) and
{ allows conversion from word to integer and
byte to shortint }
(not(
(p^.left^.resulttype^.deftype=orddef) and
(defcoll^.data^.deftype=orddef) and
(p^.left^.resulttype^.size=defcoll^.data^.size)
) and
{ an implicit pointer conversion is allowed }
not(
(p^.left^.resulttype^.deftype=pointerdef) and
(defcoll^.data^.deftype=pointerdef)
) and
{ an implicit file conversion is also allowed }
{ from a typed file to an untyped one }
not(
(p^.left^.resulttype^.deftype=filedef) and
(defcoll^.data^.deftype=filedef) and
(pfiledef(defcoll^.data)^.filetype = ft_untyped) and
(pfiledef(p^.left^.resulttype)^.filetype = ft_typed)
) and
not(is_equal(p^.left^.resulttype,defcoll^.data))) then
Message(parser_e_call_by_ref_without_typeconv);
{ don't generate an type conversion for open arrays }
{ else we loss the ranges }
if not(is_open_array(defcoll^.data)) then
begin
p^.left:=gentypeconvnode(p^.left,defcoll^.data);
firstpass(p^.left);
end;
if codegenerror then
begin
dec(parsing_para_level);
exit;
end;
end;
{ check var strings }
if (cs_strict_var_strings in aktswitches) and
(p^.left^.resulttype^.deftype=stringdef) and
(defcoll^.data^.deftype=stringdef) and
(defcoll^.paratyp=vs_var) and
not(is_equal(p^.left^.resulttype,defcoll^.data)) then
Message(parser_e_strict_var_string_violation);
{ Variablen, die call by reference <20>bergeben werden, }
{ k<>nnen nicht in ein Register kopiert werden }
{ is this usefull here ? }
{ this was missing in formal parameter list }
if defcoll^.paratyp=vs_var then
make_not_regable(p^.left);
p^.resulttype:=defcoll^.data;
end;
if p^.left^.registers32>p^.registers32 then
p^.registers32:=p^.left^.registers32;
if p^.left^.registersfpu>p^.registersfpu then
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
if p^.left^.registersmmx>p^.registersmmx then
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
dec(parsing_para_level);
end;
procedure firstcalln(var p : ptree);
type
pprocdefcoll = ^tprocdefcoll;
tprocdefcoll = record
data : pprocdef;
nextpara : pdefcoll;
firstpara : pdefcoll;
next : pprocdefcoll;
end;
var
hp,procs,hp2 : pprocdefcoll;
pd : pprocdef;
st : psymtable;
actprocsym : pprocsym;
def_from,def_to,conv_to : pdef;
pt : ptree;
exactmatch : boolean;
paralength,l : longint;
pdc : pdefcoll;
{ only Dummy }
hcvt : tconverttype;
regi : tregister;
store_valid, old_count_ref : boolean;
{ types.is_equal can't handle a formaldef ! }
function is_equal(def1,def2 : pdef) : boolean;
begin
{ all types can be passed to a formaldef }
is_equal:=(def1^.deftype=formaldef) or
(assigned(def2) and types.is_equal(def1,def2));
end;
function is_in_limit(def_from,def_to : pdef) : boolean;
begin
is_in_limit:=(def_from^.deftype = orddef) and
(def_to^.deftype = orddef) and
(porddef(def_from)^.von>porddef(def_to)^.von) and
(porddef(def_from)^.bis<porddef(def_to)^.bis);
end;
begin
{ release registers! }
{ if procdefinition<>nil then we called firstpass already }
{ it seems to be bad because of the registers }
{ at least we can avoid the overloaded search !! }
procs:=nil;
{ made this global for disposing !! }
store_valid:=must_be_valid;
if not assigned(p^.procdefinition) then
begin
must_be_valid:=false;
{ procedure variable ? }
if not(assigned(p^.right)) then
begin
if assigned(p^.left) then
begin
old_count_ref:=count_ref;
count_ref:=false;
store_valid:=must_be_valid;
must_be_valid:=false;
firstcallparan(p^.left,nil);
count_ref:=old_count_ref;
must_be_valid:=store_valid;
if codegenerror then
exit;
end;
{ determine length of parameter list }
pt:=p^.left;
paralength:=0;
while assigned(pt) do
begin
inc(paralength);
pt:=pt^.right;
end;
{ alle in Frage kommenden Prozeduren in eine }
{ verkettete Liste einf<6E>gen }
actprocsym:=p^.symtableprocentry;
pd:=actprocsym^.definition;
while assigned(pd) do
begin
{ we should also check that the overloaded function
has been declared in a unit that is in the uses !! }
{ pd^.owner should be in the symtablestack !! }
{ Laenge der deklarierten Parameterliste feststellen: }
{ not necessary why nextprocsym field }
{st:=symtablestack;
if (pd^.owner^.symtabletype<>objectsymtable) then
while assigned(st) do
begin
if (st=pd^.owner) then break;
st:=st^.next;
end;
if assigned(st) then }
begin
pdc:=pd^.para1;
l:=0;
while assigned(pdc) do
begin
inc(l);
pdc:=pdc^.next;
end;
{ nur wenn die Parameterl<72>nge pa<70>t, dann Einf<6E>gen }
if l=paralength then
begin
new(hp);
hp^.data:=pd;
hp^.next:=procs;
hp^.nextpara:=pd^.para1;
hp^.firstpara:=pd^.para1;
procs:=hp;
end;
end;
pd:=pd^.nextoverloaded;
{$ifdef CHAINPROCSYMS}
if (pd=nil) and not (p^.unit_specific) then
begin
actprocsym:=actprocsym^.nextprocsym;
if assigned(actprocsym) then
pd:=actprocsym^.definition;
end;
{$endif CHAINPROCSYMS}
end;
{ nun alle Parameter nacheinander vergleichen }
pt:=p^.left;
while assigned(pt) do
begin
{ matches a parameter of one procedure exact ? }
exactmatch:=false;
hp:=procs;
while assigned(hp) do
begin
if is_equal(hp^.nextpara^.data,pt^.resulttype) then
begin
if hp^.nextpara^.data=pt^.resulttype then
begin
pt^.exact_match_found:=true;
hp^.nextpara^.argconvtyp:=act_exact;
end
else
hp^.nextpara^.argconvtyp:=act_equal;
exactmatch:=true;
end
else
hp^.nextpara^.argconvtyp:=act_convertable;
hp:=hp^.next;
end;
{ .... if yes, del all the other procedures }
if exactmatch then
begin
{ the first .... }
while (assigned(procs)) and not(is_equal(procs^.nextpara^.data,pt^.resulttype)) do
begin
hp:=procs^.next;
dispose(procs);
procs:=hp;
end;
{ and the others }
hp:=procs;
while (assigned(hp)) and assigned(hp^.next) do
begin
if not(is_equal(hp^.next^.nextpara^.data,pt^.resulttype)) then
begin
hp2:=hp^.next^.next;
dispose(hp^.next);
hp^.next:=hp2;
end
else
hp:=hp^.next;
end;
end
{ sollte nirgendwo ein Parameter exakt passen, }
{ so alle Prozeduren entfernen, bei denen }
{ der Parameter auch nach einer impliziten }
{ Typkonvertierung nicht passt }
else
begin
{ erst am Anfang }
while (assigned(procs)) and
not(isconvertable(pt^.resulttype,procs^.nextpara^.data,hcvt,pt^.left^.treetype)) do
begin
hp:=procs^.next;
dispose(procs);
procs:=hp;
end;
{ und jetzt aus der Mitte }
hp:=procs;
while (assigned(hp)) and assigned(hp^.next) do
begin
if not(isconvertable(pt^.resulttype,hp^.next^.nextpara^.data,
hcvt,pt^.left^.treetype)) then
begin
hp2:=hp^.next^.next;
dispose(hp^.next);
hp^.next:=hp2;
end
else
hp:=hp^.next;
end;
end;
{ nun bei denn Prozeduren den nextpara-Zeiger auf den }
{ naechsten Parameter setzen }
hp:=procs;
while assigned(hp) do
begin
hp^.nextpara:=hp^.nextpara^.next;
hp:=hp^.next;
end;
pt:=pt^.right;
end;
if procs=nil then
if (parsing_para_level=0) or (p^.left<>nil) then
begin
Message(parser_e_illegal_parameter_list);
exit;
end
else
begin
{ try to convert to procvar }
p^.treetype:=loadn;
p^.resulttype:=pprocsym(p^.symtableprocentry)^.definition;
p^.symtableentry:=p^.symtableprocentry;
p^.is_first:=false;
p^.disposetyp:=dt_nothing;
firstpass(p);
exit;
end;
{ if there are several choices left then for orddef }
{ if a type is totally included in the other }
{ we don't fear an overflow , }
{ so we can do as if it is an exact match }
{ this will convert integer to longint }
{ rather than to words }
{ conversion of byte to integer or longint }
{would still not be solved }
if assigned(procs^.next) then
begin
hp:=procs;
while assigned(hp) do
begin
hp^.nextpara:=hp^.firstpara;
hp:=hp^.next;
end;
pt:=p^.left;
while assigned(pt) do
begin
{ matches a parameter of one procedure exact ? }
exactmatch:=false;
def_from:=pt^.resulttype;
hp:=procs;
while assigned(hp) do
begin
if not is_equal(hp^.nextpara^.data,pt^.resulttype) then
begin
def_to:=hp^.nextpara^.data;
if (def_from^.deftype=orddef) and (def_to^.deftype=orddef) then
if is_in_limit(def_from,def_to) or
((hp^.nextpara^.paratyp=vs_var) and
(def_from^.size=def_to^.size)) then
begin
exactmatch:=true;
conv_to:=def_to;
end;
end;
hp:=hp^.next;
end;
{ .... if yes, del all the other procedures }
if exactmatch then
begin
{ the first .... }
while (assigned(procs)) and not(is_in_limit(def_from,procs^.nextpara^.data)) do
begin
hp:=procs^.next;
dispose(procs);
procs:=hp;
end;
{ and the others }
hp:=procs;
while (assigned(hp)) and assigned(hp^.next) do
begin
if not(is_in_limit(def_from,hp^.next^.nextpara^.data)) then
begin
hp2:=hp^.next^.next;
dispose(hp^.next);
hp^.next:=hp2;
end
else
begin
def_to:=hp^.next^.nextpara^.data;
if (conv_to^.size>def_to^.size) or
((porddef(conv_to)^.von<porddef(def_to)^.von) and
(porddef(conv_to)^.bis>porddef(def_to)^.bis)) then
begin
hp2:=procs;
procs:=hp;
conv_to:=def_to;
dispose(hp2);
end
else
hp:=hp^.next;
end;
end;
end;
{ nun bei denn Prozeduren den nextpara-Zeiger auf den }
{ naechsten Parameter setzen }
hp:=procs;
while assigned(hp) do
begin
hp^.nextpara:=hp^.nextpara^.next;
hp:=hp^.next;
end;
pt:=pt^.right;
end;
end;
{ let's try to eliminate equal is exact is there }
{if assigned(procs^.next) then
begin
pt:=p^.left;
while assigned(pt) do
begin
if pt^.exact_match_found then
begin
hp:=procs;
while (assigned(procs)) and (procs^.nextpara^.data<>pt^.resulttype) do
begin
hp:=procs^.next;
dispose(procs);
procs:=hp;
end;
end;
pt:=pt^.right;
end;
end; }
{$ifndef CHAINPROCSYMS}
if assigned(procs^.next) then
Message(cg_e_cant_choose_overload_function);
{$else CHAINPROCSYMS}
if assigned(procs^.next) then
{ if the last retained is the only one }
{ from a unit it is OK PM }
{ the last is the one coming from the first symtable }
{ as the diff defcoll are inserted in front }
begin
hp2:=procs;
while assigned(hp2^.next) and assigned(hp2^.next^.next) do
hp2:=hp2^.next;
if (hp2^.data^.owner<>hp2^.next^.data^.owner) then
begin
hp:=procs^.next;
{hp2 is the correct one }
hp2:=hp2^.next;
while hp<>hp2 do
begin
dispose(procs);
procs:=hp;
hp:=procs^.next;
end;
procs:=hp2;
end
else
Message(cg_e_cant_choose_overload_function);
error(too_much_matches);
end;
{$endif CHAINPROCSYMS}
{$ifdef UseBrowser}
add_new_ref(procs^.data^.lastref);
{$endif UseBrowser}
p^.procdefinition:=procs^.data;
p^.resulttype:=procs^.data^.retdef;
p^.location.loc:=LOC_MEM;
{$ifdef CHAINPROCSYMS}
{ object with method read;
call to read(x) will be a usual procedure call }
if assigned(p^.methodpointer) and
(p^.procdefinition^._class=nil) then
begin
{ not ok for extended }
case p^.methodpointer^.treetype of
typen,hnewn : fatalerror(no_para_match);
end;
disposetree(p^.methodpointer);
p^.methodpointer:=nil;
end;
{$endif CHAINPROCSYMS}
{ work trough all parameters to insert the type conversions }
if assigned(p^.left) then
begin
old_count_ref:=count_ref;
count_ref:=true;
firstcallparan(p^.left,p^.procdefinition^.para1);
count_ref:=old_count_ref;
end;
{ handle predefined procedures }
if (p^.procdefinition^.options and pointernproc)<>0 then
begin
{ settextbuf needs two args }
if assigned(p^.left^.right) then
pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,p^.left)
else
begin
pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,p^.left^.left);
putnode(p^.left);
end;
putnode(p);
firstpass(pt);
{ was placed after the exit }
{ caused GPF }
{ error caused and corrected by (PM) }
p:=pt;
must_be_valid:=store_valid;
if codegenerror then
exit;
dispose(procs);
exit;
end
else
{ no intern procedure => we do a call }
procinfo.flags:=procinfo.flags or pi_do_call;
{ calc the correture value for the register }
{$ifdef i386}
{ calc the correture value for the register }
for regi:=R_EAX to R_EDI do
begin
if (p^.procdefinition^.usedregisters and ($80 shr word(regi)))<>0 then
inc(reg_pushes[regi],t_times*2);
end;
{$endif}
{$ifdef m68k}
for regi:=R_D0 to R_A6 do
begin
if (p^.procdefinition^.usedregisters and ($800 shr word(regi)))<>0 then
inc(reg_pushes[regi],t_times*2);
end;
{$endif}
end
else
begin
{ procedure variable }
{ die Typen der Parameter berechnen }
{ procedure does a call }
procinfo.flags:=procinfo.flags or pi_do_call;
{$ifdef i386}
{ calc the correture value for the register }
for regi:=R_EAX to R_EDI do
inc(reg_pushes[regi],t_times*2);
{$endif}
{$ifdef m68k}
{ calc the correture value for the register }
for regi:=R_D0 to R_A6 do
inc(reg_pushes[regi],t_times*2);
{$endif}
if assigned(p^.left) then
begin
old_count_ref:=count_ref;
count_ref:=false;
firstcallparan(p^.left,nil);
count_ref:=old_count_ref;
if codegenerror then
exit;
end;
firstpass(p^.right);
{ check the parameters }
pdc:=pprocvardef(p^.right^.resulttype)^.para1;
pt:=p^.left;
while assigned(pdc) and assigned(pt) do
begin
pt:=pt^.right;
pdc:=pdc^.next;
end;
if assigned(pt) or assigned(pdc) then
Message(parser_e_illegal_parameter_list);
{ insert type conversions }
if assigned(p^.left) then
begin
old_count_ref:=count_ref;
count_ref:=true;
firstcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1);
count_ref:=old_count_ref;
if codegenerror then
exit;
end;
p^.resulttype:=pprocvardef(p^.right^.resulttype)^.retdef;
{ this was missing , leads to a bug below if
the procvar is a function }
p^.procdefinition:=pprocdef(p^.right^.resulttype);
end;
end; { not assigned(p^.procdefinition) }
{ get a register for the return value }
if (p^.resulttype<>pdef(voiddef)) then
begin
{ the constructor returns the result with the flags }
if (p^.procdefinition^.options and poconstructor)<>0 then
begin
{ extra handling of classes }
{ p^.methodpointer should be assigned! }
if assigned(p^.methodpointer) and assigned(p^.methodpointer^.resulttype) and
(p^.methodpointer^.resulttype^.deftype=classrefdef) then
begin
p^.location.loc:=LOC_REGISTER;
p^.registers32:=1;
end
else
p^.location.loc:=LOC_FLAGS;
end
else
begin
{$ifdef SUPPORT_MMX}
if (cs_mmx in aktswitches) and
is_mmx_able_array(p^.resulttype) then
begin
p^.location.loc:=LOC_MMXREGISTER;
p^.registersmmx:=1;
end
else
{$endif SUPPORT_MMX}
if ret_in_acc(p^.resulttype) then
begin
p^.location.loc:=LOC_REGISTER;
p^.registers32:=1;
end
else if (p^.resulttype^.deftype=floatdef) then
begin
p^.location.loc:=LOC_FPU;
p^.registersfpu:=1;
end
end;
end;
{ if this is a call to a method calc the registers }
if (p^.methodpointer<>nil) then
begin
case p^.methodpointer^.treetype of
{ but only, if this is not a supporting node }
typen,hnewn : ;
else
begin
{ R.Assign is not a constructor !!! }
{ but for R^.Assign, R must be valid !! }
if ((p^.procdefinition^.options and poconstructor) <> 0) or
((p^.methodpointer^.treetype=loadn) and
((pobjectdef(p^.methodpointer^.resulttype)^.options and oo_hasvirtual) = 0)) then
must_be_valid:=false
else
must_be_valid:=true;
firstpass(p^.methodpointer);
p^.registersfpu:=max(p^.methodpointer^.registersfpu,p^.registersfpu);
p^.registers32:=max(p^.methodpointer^.registers32,p^.registers32);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.methodpointer^.registersmmx,p^.registersmmx);
{$endif SUPPORT_MMX}
end;
end;
end;
{ determine the registers of the procedure variable }
if assigned(p^.right) then
begin
p^.registersfpu:=max(p^.right^.registersfpu,p^.registersfpu);
p^.registers32:=max(p^.right^.registers32,p^.registers32);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.right^.registersmmx,p^.registersmmx);
{$endif SUPPORT_MMX}
end;
{ determine the registers of the procedure }
if assigned(p^.left) then
begin
p^.registersfpu:=max(p^.left^.registersfpu,p^.registersfpu);
p^.registers32:=max(p^.left^.registers32,p^.registers32);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,p^.registersmmx);
{$endif SUPPORT_MMX}
end;
if assigned(procs) then
dispose(procs);
must_be_valid:=store_valid;
end;
procedure firstfuncret(var p : ptree);
begin
{$ifdef TEST_FUNCRET}
p^.resulttype:=p^.retdef;
p^.location.loc:=LOC_REFERENCE;
if ret_in_param(p^.retdef) or
(@procinfo<>pprocinfo(p^.funcretprocinfo)) then
p^.registers32:=1;
{$ifdef GDB}
if must_be_valid and not pprocinfo(p^.funcretprocinfo)^.funcret_is_valid then
note(uninitialized_function_return);
if count_ref then pprocinfo(p^.funcretprocinfo)^.funcret_is_valid:=true;
{$endif * GDB *}
{$else TEST_FUNCRET}
p^.resulttype:=procinfo.retdef;
p^.location.loc:=LOC_REFERENCE;
if ret_in_param(procinfo.retdef) then
p^.registers32:=1;
{$ifdef GDB}
if must_be_valid and
not(procinfo.funcret_is_valid) and
((procinfo.flags and pi_uses_asm)=0) then
Message(sym_w_function_result_not_set);
if count_ref then procinfo.funcret_is_valid:=true;
{$endif * GDB *}
{$endif TEST_FUNCRET}
end;
{ intern inline suborutines }
procedure firstinline(var p : ptree);
var
hp,hpp : ptree;
isreal,store_valid,file_is_typed : boolean;
convtyp : tconverttype;
procedure do_lowhigh(adef : pdef);
var
v : longint;
enum : penumsym;
begin
case Adef^.deftype of
orddef:
begin
if p^.inlinenumber=in_low_x then
v:=porddef(Adef)^.von
else
v:=porddef(Adef)^.bis;
hp:=genordinalconstnode(v,adef);
disposetree(p);
p:=hp;
end;
enumdef:
begin
enum:=Penumdef(Adef)^.first;
if p^.inlinenumber=in_high_x then
while enum^.next<>nil do
enum:=enum^.next;
hp:=genenumnode(enum);
disposetree(p);
p:=hp;
end
end;
end;
begin
{ if we handle writeln; p^.left contains no valid address }
if assigned(p^.left) then
begin
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
set_location(p^.location,p^.left^.location);
end;
store_valid:=must_be_valid;
if not (p^.inlinenumber in [in_read_x,in_readln_x,in_sizeof_x,
in_typeof_x,in_ord_x,
in_reset_typedfile,in_rewrite_typedfile]) then
must_be_valid:=true
else must_be_valid:=false;
case p^.inlinenumber of
in_lo_word,in_hi_word:
begin
if p^.registers32<1 then
p^.registers32:=1;
p^.resulttype:=u8bitdef;
p^.location.loc:=LOC_REGISTER;
end;
in_lo_long,in_hi_long:
begin
if p^.registers32<1 then
p^.registers32:=1;
p^.resulttype:=u16bitdef;
p^.location.loc:=LOC_REGISTER;
end;
in_sizeof_x:
begin
if p^.registers32<1 then
p^.registers32:=1;
p^.resulttype:=s32bitdef;
p^.location.loc:=LOC_REGISTER;
end;
in_typeof_x:
begin
if p^.registers32<1 then
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
p^.resulttype:=voidpointerdef;
end;
in_ord_x:
begin
if (p^.left^.treetype=ordconstn) then
begin
hp:=genordinalconstnode(p^.left^.value,s32bitdef);
disposetree(p);
p:=hp;
firstpass(p);
end
else
begin
if (p^.left^.resulttype^.deftype=orddef) then
if (porddef(p^.left^.resulttype)^.typ=uchar) or
(porddef(p^.left^.resulttype)^.typ=bool8bit) then
begin
if porddef(p^.left^.resulttype)^.typ=bool8bit then
begin
hp:=gentypeconvnode(p^.left,u8bitdef);
putnode(p);
p:=hp;
p^.convtyp:=tc_bool_2_u8bit;
p^.explizit:=true;
firstpass(p);
end
else
begin
hp:=gentypeconvnode(p^.left,u8bitdef);
putnode(p);
p:=hp;
p^.explizit:=true;
firstpass(p);
end;
end
{ can this happen ? }
else if (porddef(p^.left^.resulttype)^.typ=uvoid) then
Message(sym_e_type_mismatch)
else
{ all other orddef need no transformation }
begin
hp:=p^.left;
putnode(p);
p:=hp;
end
else if (p^.left^.resulttype^.deftype=enumdef) then
begin
hp:=gentypeconvnode(p^.left,s32bitdef);
putnode(p);
p:=hp;
p^.explizit:=true;
firstpass(p);
end
else
begin
{ can anything else be ord() ?}
Message(sym_e_type_mismatch);
end;
end;
end;
in_chr_byte:
begin
hp:=gentypeconvnode(p^.left,cchardef);
putnode(p);
p:=hp;
p^.explizit:=true;
firstpass(p);
end;
in_length_string:
begin
p^.resulttype:=u8bitdef;
{ String nach Stringkonvertierungen brauchen wir hier nicht }
if (p^.left^.treetype=typeconvn) and
(p^.left^.left^.resulttype^.deftype=stringdef) then
begin
hp:=p^.left^.left;
putnode(p^.left);
p^.left:=hp;
end;
{ evalutes length of constant strings direct }
if (p^.left^.treetype=stringconstn) then
begin
hp:=genordinalconstnode(length(p^.left^.values^),s32bitdef);
disposetree(p);
firstpass(hp);
p:=hp;
end;
end;
in_assigned_x:
begin
p^.resulttype:=booldef;
p^.location.loc:=LOC_FLAGS;
end;
in_pred_x,
in_succ_x:
begin
p^.resulttype:=p^.left^.resulttype;
p^.location.loc:=LOC_REGISTER;
if not is_ordinal(p^.resulttype) then
Message(sym_e_type_mismatch)
else
begin
if (p^.resulttype^.deftype=enumdef) and
(penumdef(p^.resulttype)^.has_jumps) then
begin
Message(parser_e_succ_and_pred_enums_with_assign_not_possible);
exit;
end;
if p^.left^.treetype=ordconstn then
begin
if p^.inlinenumber=in_pred_x then
hp:=genordinalconstnode(p^.left^.value+1,
p^.left^.resulttype)
else
hp:=genordinalconstnode(p^.left^.value-1,
p^.left^.resulttype);
disposetree(p);
firstpass(hp);
p:=hp;
end;
end;
end;
in_dec_dword,
in_dec_word,
in_dec_byte,
in_inc_dword,
in_inc_word,
in_inc_byte :
begin
p^.resulttype:=voiddef;
if p^.left^.location.loc<>LOC_REFERENCE then
Message(cg_e_illegal_expression);
end;
in_inc_x,
in_dec_x:
begin
p^.resulttype:=voiddef;
if assigned(p^.left) then
begin
firstcallparan(p^.left,nil);
{ first param must be var }
if p^.left^.left^.location.loc<>LOC_REFERENCE then
Message(cg_e_illegal_expression);
{ check type }
if (p^.left^.resulttype^.deftype=pointerdef) or
(p^.left^.resulttype^.deftype=enumdef) or
( (p^.left^.resulttype^.deftype=orddef) and
(porddef(p^.left^.resulttype)^.typ in [u8bit,s8bit,u16bit,s16bit,u32bit,s32bit])
) then
begin
{ two paras ? }
if assigned(p^.left^.right) then
begin
{ insert a type conversion }
{ the second param is always longint }
p^.left^.right^.left:=gentypeconvnode(
p^.left^.right^.left,
s32bitdef);
{ check the type conversion }
firstpass(p^.left^.right^.left);
if assigned(p^.left^.right^.right) then
Message(cg_e_illegal_expression);
end;
end
else
Message(sym_e_type_mismatch);
end
else
Message(sym_e_type_mismatch);
end;
in_read_x,
in_readln_x,
in_write_x,
in_writeln_x :
begin
{ needs a call }
procinfo.flags:=procinfo.flags or pi_do_call;
p^.resulttype:=voiddef;
{ we must know if it is a typed file or not }
{ but we must first do the firstpass for it }
file_is_typed:=false;
if assigned(p^.left) then
begin
firstcallparan(p^.left,nil);
{ now we can check }
hp:=p^.left;
while assigned(hp^.right) do
hp:=hp^.right;
{ if resulttype is not assigned, then automatically }
{ file is not typed. }
if assigned(hp) and assigned(hp^.resulttype) then
Begin
if (hp^.resulttype^.deftype=filedef) and
(pfiledef(hp^.resulttype)^.filetype=ft_typed) then
begin
file_is_typed:=true;
{ test the type here
so we can use a trick in cgi386 (PM) }
hpp:=p^.left;
while (hpp<>hp) do
begin
{ should we allow type conversion ? (PM)
if not isconvertable(hpp^.resulttype,
pfiledef(hp^.resulttype)^.typed_as,convtyp,hpp^.treetype) then
Message(sym_e_type_mismatch);
if not(is_equal(hpp^.resulttype,pfiledef(hp^.resulttype)^.typed_as)) then
begin
hpp^.left:=gentypeconvnode(hpp^.left,pfiledef(hp^.resulttype)^.typed_as);
end; }
if not is_equal(hpp^.resulttype,pfiledef(hp^.resulttype)^.typed_as) then
Message(sym_e_type_mismatch);
hpp:=hpp^.right;
end;
{ once again for typeconversions }
firstcallparan(p^.left,nil);
end;
end; { endif assigned(hp) }
{ insert type conversions for write(ln) }
if (not file_is_typed) and
((p^.inlinenumber=in_write_x) or (p^.inlinenumber=in_writeln_x)) then
begin
hp:=p^.left;
while assigned(hp) do
begin
if assigned(hp^.left^.resulttype) then
begin
if hp^.left^.resulttype^.deftype=floatdef then
begin
isreal:=true;
end
else if hp^.left^.resulttype^.deftype=orddef then
case porddef(hp^.left^.resulttype)^.typ of
u8bit,s8bit,
u16bit,s16bit :
hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
end
{ but we convert only if the first index<>0, because in this case }
{ we have a ASCIIZ string }
else if (hp^.left^.resulttype^.deftype=arraydef) and
(parraydef(hp^.left^.resulttype)^.lowrange<>0) and
(parraydef(hp^.left^.resulttype)^.definition^.deftype=orddef) and
(porddef(parraydef(hp^.left^.resulttype)^.definition)^.typ=uchar) then
hp^.left:=gentypeconvnode(hp^.left,cstringdef);
end;
hp:=hp^.right;
end;
end;
{ nochmals alle Parameter bearbeiten }
firstcallparan(p^.left,nil);
end;
end;
in_settextbuf_file_x :
begin
{ warning here p^.left is the callparannode
not the argument directly }
{ p^.left^.left is text var }
{ p^.left^.right^.left is the buffer var }
{ firstcallparan(p^.left,nil);
already done in firstcalln }
{ now we know the type of buffer }
getsymonlyin(systemunit,'SETTEXTBUF');
hp:=gencallnode(pprocsym(srsym),systemunit);
hp^.left:=gencallparanode(
genordinalconstnode(p^.left^.left^.resulttype^.size,s32bitdef),p^.left);
putnode(p);
p:=hp;
firstpass(p);
end;
{ the firstpass of the arg has been done in firstcalln ? }
in_reset_typedfile,in_rewrite_typedfile :
begin
procinfo.flags:=procinfo.flags or pi_do_call;
{ to be sure the right definition is loaded }
p^.left^.resulttype:=nil;
firstload(p^.left);
p^.resulttype:=voiddef;
end;
in_str_x_string :
begin
procinfo.flags:=procinfo.flags or pi_do_call;
p^.resulttype:=voiddef;
if assigned(p^.left) then
begin
hp:=p^.left^.right;
{ first pass just the string for first local use }
must_be_valid:=false;
count_ref:=true;
p^.left^.right:=nil;
firstcallparan(p^.left,nil);
p^.left^.right:=hp;
must_be_valid:=true;
firstcallparan(p^.left,nil);
hp:=p^.left;
isreal:=false;
{ valid string ? }
if not assigned(hp) or
(hp^.left^.resulttype^.deftype<>stringdef) or
(hp^.right=nil) or
(hp^.left^.location.loc<>LOC_REFERENCE) then
Message(cg_e_illegal_expression);
{ !!!! check length of string }
while assigned(hp^.right) do hp:=hp^.right;
{ check and convert the first param }
if hp^.is_colon_para then
Message(cg_e_illegal_expression)
else if hp^.resulttype^.deftype=orddef then
case porddef(hp^.left^.resulttype)^.typ of
u8bit,s8bit,
u16bit,s16bit :
hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
end
else if hp^.resulttype^.deftype=floatdef then
begin
isreal:=true;
end
else Message(cg_e_illegal_expression);
{ some format options ? }
hp:=p^.left^.right;
if assigned(hp) and hp^.is_colon_para then
begin
hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
hp:=hp^.right;
end;
if assigned(hp) and hp^.is_colon_para then
begin
if isreal then
hp^.left:=gentypeconvnode(hp^.left,s32bitdef)
else
Message(parser_e_illegal_colon_qualifier);
hp:=hp^.right;
end;
{ for first local use }
must_be_valid:=false;
count_ref:=true;
if assigned(hp) then
firstcallparan(hp,nil);
end
else
Message(parser_e_illegal_parameter_list);
{ check params once more }
if codegenerror then
exit;
must_be_valid:=true;
firstcallparan(p^.left,nil);
end;
in_low_x,in_high_x:
begin
if p^.left^.treetype in [typen,loadn] then
begin
case p^.left^.resulttype^.deftype of
orddef,enumdef:
begin
do_lowhigh(p^.left^.resulttype);
firstpass(p);
end;
setdef:
begin
do_lowhigh(Psetdef(p^.left^.resulttype)^.setof);
firstpass(p);
end;
arraydef:
begin
if is_open_array(p^.left^.resulttype) then
begin
if p^.inlinenumber=in_low_x then
begin
hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.lowrange,s32bitdef);
disposetree(p);
p:=hp;
firstpass(p);
end
else
begin
p^.resulttype:=s32bitdef;
p^.registers32:=max(1,
p^.registers32);
p^.location.loc:=LOC_REGISTER;
end;
end
else
begin
if p^.inlinenumber=in_low_x then
hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.lowrange,s32bitdef)
else
hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.highrange,s32bitdef);
disposetree(p);
p:=hp;
firstpass(p);
end;
end;
stringdef:
begin
if p^.inlinenumber=in_low_x then
hp:=genordinalconstnode(0,u8bitdef)
else
hp:=genordinalconstnode(Pstringdef(p^.left^.resulttype)^.len,u8bitdef);
disposetree(p);
p:=hp;
firstpass(p);
end;
else
Message(sym_e_type_mismatch);
end;
end
else
Message(parser_e_varid_or_typeid_expected);
end
else internalerror(8);
end;
must_be_valid:=store_valid;
end;
procedure firstsubscriptn(var p : ptree);
begin
firstpass(p^.left);
if codegenerror then
exit;
p^.resulttype:=p^.vs^.definition;
if count_ref and not must_be_valid then
if (p^.vs^.properties and sp_protected)<>0 then
Message(parser_e_cant_write_protected_member);
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
{ classes must be dereferenced implicit }
if (p^.left^.resulttype^.deftype=objectdef) and
pobjectdef(p^.left^.resulttype)^.isclass then
begin
if p^.registers32=0 then
p^.registers32:=1;
p^.location.loc:=LOC_REFERENCE;
end
else
begin
if (p^.left^.location.loc<>LOC_MEM) and
(p^.left^.location.loc<>LOC_REFERENCE) then
Message(cg_e_illegal_expression);
set_location(p^.location,p^.left^.location);
end;
end;
procedure firstselfn(var p : ptree);
begin
if (p^.resulttype^.deftype=classrefdef) or
((p^.resulttype^.deftype=objectdef)
and pobjectdef(p^.resulttype)^.isclass
) then
p^.location.loc:=LOC_REGISTER
else
p^.location.loc:=LOC_REFERENCE;
end;
procedure firsttypen(var p : ptree);
begin
{ DM: Why not allowed? For example: low(word) results in a type
id of word.
error(typeid_here_not_allowed);}
end;
procedure firsthnewn(var p : ptree);
begin
end;
procedure firsthdisposen(var p : ptree);
begin
firstpass(p^.left);
if codegenerror then
exit;
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
if p^.registers32<1 then
p^.registers32:=1;
{
if p^.left^.location.loc<>LOC_REFERENCE then
Message(cg_e_illegal_expression);
}
p^.location.loc:=LOC_REFERENCE;
p^.resulttype:=ppointerdef(p^.left^.resulttype)^.definition;
end;
procedure firstnewn(var p : ptree);
begin
{ Standardeinleitung }
firstpass(p^.left);
if codegenerror then
exit;
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
{ result type is already set }
procinfo.flags:=procinfo.flags or pi_do_call;
p^.location.loc:=LOC_REGISTER;
end;
procedure firstsimplenewdispose(var p : ptree);
begin
{ this cannot be in a register !! }
make_not_regable(p^.left);
firstpass(p^.left);
{ check the type }
if (p^.left^.resulttype=nil) or (p^.left^.resulttype^.deftype<>pointerdef) then
Message(parser_e_pointer_type_expected);
if (p^.left^.location.loc<>LOC_REFERENCE) {and
(p^.left^.location.loc<>LOC_CREGISTER)} then
Message(cg_e_illegal_expression);
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
p^.resulttype:=voiddef;
procinfo.flags:=procinfo.flags or pi_do_call;
end;
procedure firstsetcons(var p : ptree);
var
hp : ptree;
begin
p^.location.loc:=LOC_MEM;
hp:=p^.left;
{ is done by getnode*
p^.registers32:=0;
p^.registersfpu:=0;
}
while assigned(hp) do
begin
firstpass(hp^.left);
if codegenerror then
exit;
p^.registers32:=max(p^.registers32,hp^.left^.registers32);
p^.registersfpu:=max(p^.registersfpu,hp^.left^.registersfpu);;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.registersmmx,hp^.left^.registersmmx);
{$endif SUPPORT_MMX}
hp:=hp^.right;
end;
{ result type is already set }
end;
procedure firstin(var p : ptree);
begin
p^.location.loc:=LOC_FLAGS;
p^.resulttype:=booldef;
firstpass(p^.right);
if codegenerror then
exit;
if p^.right^.resulttype^.deftype<>setdef then
Message(sym_e_set_expected);
firstpass(p^.left);
if codegenerror then
exit;
p^.left:=gentypeconvnode(p^.left,psetdef(p^.right^.resulttype)^.setof);
firstpass(p^.left);
if codegenerror then
exit;
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
{$endif SUPPORT_MMX}
{ this is not allways true due to optimization }
{ but if we don't set this we get problems with optimizing self code }
if psetdef(p^.right^.resulttype)^.settype<>smallset then
procinfo.flags:=procinfo.flags or pi_do_call;
end;
{ !!!!!!!!!!!! unused }
procedure firstexpr(var p : ptree);
begin
firstpass(p^.left);
if codegenerror then
exit;
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
if (cs_extsyntax in aktswitches) and (p^.left^.resulttype<>pdef(voiddef)) then
Message(cg_e_illegal_expression);
end;
procedure firstblock(var p : ptree);
var
hp : ptree;
count : longint;
begin
count:=0;
hp:=p^.left;
while assigned(hp) do
begin
if cs_maxoptimieren in aktswitches then
begin
{ Codeumstellungen }
{ Funktionsresultate an exit anh<6E>ngen }
{ this is wrong for string or other complex
result types !!! }
if ret_in_acc(procinfo.retdef) and
assigned(hp^.left) and
(hp^.left^.right^.treetype=exitn) and
(hp^.right^.treetype=assignn) and
(hp^.right^.left^.treetype=funcretn) then
begin
if assigned(hp^.left^.right^.left) then
Message(cg_n_inefficient_code)
else
begin
hp^.left^.right^.left:=getcopy(hp^.right^.right);
disposetree(hp^.right);
hp^.right:=nil;
end;
end
{ warning if unreachable code occurs and elimate this }
else if (hp^.right^.treetype in
[exitn,breakn,continuen,goton]) and
assigned(hp^.left) and
(hp^.left^.treetype<>labeln) then
begin
{ use correct line number }
current_module^.current_inputfile:=hp^.left^.inputfile;
current_module^.current_inputfile^.line_no:=hp^.left^.line;
disposetree(hp^.left);
hp^.left:=nil;
Message(cg_w_unreachable_code);
{ old lines }
current_module^.current_inputfile:=hp^.right^.inputfile;
current_module^.current_inputfile^.line_no:=hp^.right^.line;
end;
end;
if assigned(hp^.right) then
begin
cleartempgen;
firstpass(hp^.right);
if codegenerror then
exit;
hp^.registers32:=hp^.right^.registers32;
hp^.registersfpu:=hp^.right^.registersfpu;
{$ifdef SUPPORT_MMX}
hp^.registersmmx:=hp^.right^.registersmmx;
{$endif SUPPORT_MMX}
end
else
hp^.registers32:=0;
if hp^.registers32>p^.registers32 then
p^.registers32:=hp^.registers32;
if hp^.registersfpu>p^.registersfpu then
p^.registersfpu:=hp^.registersfpu;
{$ifdef SUPPORT_MMX}
if hp^.registersmmx>p^.registersmmx then
p^.registersmmx:=hp^.registersmmx;
{$endif}
inc(count);
hp:=hp^.left;
end;
{ p^.registers32:=round(p^.registers32/count); }
end;
procedure first_while_repeat(var p : ptree);
var
old_t_times : longint;
begin
old_t_times:=t_times;
{ Registergewichtung bestimmen }
if not(cs_littlesize in aktswitches ) then
t_times:=t_times*8;
cleartempgen;
must_be_valid:=true;
firstpass(p^.left);
if codegenerror then
exit;
if not((p^.left^.resulttype^.deftype=orddef) and
(porddef(p^.left^.resulttype)^.typ=bool8bit)) then
begin
Message(sym_e_type_mismatch);
exit;
end;
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
{ loop instruction }
if assigned(p^.right) then
begin
cleartempgen;
firstpass(p^.right);
if codegenerror then
exit;
if p^.registers32<p^.right^.registers32 then
p^.registers32:=p^.right^.registers32;
if p^.registersfpu<p^.right^.registersfpu then
p^.registersfpu:=p^.right^.registersfpu;
{$ifdef SUPPORT_MMX}
if p^.registersmmx<p^.right^.registersmmx then
p^.registersmmx:=p^.right^.registersmmx;
{$endif SUPPORT_MMX}
end;
t_times:=old_t_times;
end;
procedure firstif(var p : ptree);
var
old_t_times : longint;
hp : ptree;
begin
old_t_times:=t_times;
cleartempgen;
must_be_valid:=true;
firstpass(p^.left);
if codegenerror then
exit;
if not((p^.left^.resulttype^.deftype=orddef) and
(porddef(p^.left^.resulttype)^.typ=bool8bit)) then
begin
Message(sym_e_type_mismatch);
exit;
end;
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
{ determines registers weigths }
if not(cs_littlesize in aktswitches ) then
t_times:=t_times div 2;
if t_times=0 then
t_times:=1;
{ if path }
if assigned(p^.right) then
begin
cleartempgen;
firstpass(p^.right);
if codegenerror then
exit;
if p^.registers32<p^.right^.registers32 then
p^.registers32:=p^.right^.registers32;
if p^.registersfpu<p^.right^.registersfpu then
p^.registersfpu:=p^.right^.registersfpu;
{$ifdef SUPPORT_MMX}
if p^.registersmmx<p^.right^.registersmmx then
p^.registersmmx:=p^.right^.registersmmx;
{$endif SUPPORT_MMX}
end;
{ else path }
if assigned(p^.t1) then
begin
cleartempgen;
firstpass(p^.t1);
if codegenerror then
exit;
if p^.registers32<p^.t1^.registers32 then
p^.registers32:=p^.t1^.registers32;
if p^.registersfpu<p^.t1^.registersfpu then
p^.registersfpu:=p^.t1^.registersfpu;
{$ifdef SUPPORT_MMX}
if p^.registersmmx<p^.t1^.registersmmx then
p^.registersmmx:=p^.t1^.registersmmx;
{$endif SUPPORT_MMX}
end;
if p^.left^.treetype=ordconstn then
begin
{ optimize }
if p^.left^.value=1 then
begin
disposetree(p^.left);
hp:=p^.right;
disposetree(p^.t1);
{ we cannot set p to nil !!! }
if assigned(hp) then
begin
putnode(p);
p:=hp;
end
else
begin
p^.left:=nil;
p^.t1:=nil;
p^.treetype:=nothingn;
end;
end
else
begin
disposetree(p^.left);
hp:=p^.t1;
disposetree(p^.right);
{ we cannot set p to nil !!! }
if assigned(hp) then
begin
putnode(p);
p:=hp;
end
else
begin
p^.left:=nil;
p^.right:=nil;
p^.treetype:=nothingn;
end;
end;
end;
t_times:=old_t_times;
end;
procedure firstexitn(var p : ptree);
begin
if assigned(p^.left) then
begin
firstpass(p^.left);
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
end;
end;
procedure firstfor(var p : ptree);
var
old_t_times : longint;
begin
{ Registergewichtung bestimmen
(nicht genau), }
old_t_times:=t_times;
if not(cs_littlesize in aktswitches ) then
t_times:=t_times*8;
cleartempgen;
if p^.t1<>nil then
firstpass(p^.t1);
p^.registers32:=p^.t1^.registers32;
p^.registersfpu:=p^.t1^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
if p^.left^.treetype<>assignn then
Message(cg_e_illegal_expression);
{ Laufvariable retten }
p^.t2:=getcopy(p^.left^.left);
{ Check count var }
if (p^.t2^.treetype<>loadn) then
Message(cg_e_illegal_count_var);
if (not(is_ordinal(p^.t2^.resulttype))) then
Message(parser_e_ordinal_expected);
cleartempgen;
must_be_valid:=false;
firstpass(p^.left);
must_be_valid:=true;
if p^.left^.registers32>p^.registers32 then
p^.registers32:=p^.left^.registers32;
if p^.left^.registersfpu>p^.registersfpu then
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
if p^.left^.registersmmx>p^.registersmmx then
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
cleartempgen;
firstpass(p^.t2);
if p^.t2^.registers32>p^.registers32 then
p^.registers32:=p^.t2^.registers32;
if p^.t2^.registersfpu>p^.registersfpu then
p^.registersfpu:=p^.t2^.registersfpu;
{$ifdef SUPPORT_MMX}
if p^.t2^.registersmmx>p^.registersmmx then
p^.registersmmx:=p^.t2^.registersmmx;
{$endif SUPPORT_MMX}
cleartempgen;
firstpass(p^.right);
if p^.right^.treetype<>ordconstn then
begin
p^.right:=gentypeconvnode(p^.right,p^.t2^.resulttype);
cleartempgen;
firstpass(p^.right);
end;
if p^.right^.registers32>p^.registers32 then
p^.registers32:=p^.right^.registers32;
if p^.right^.registersfpu>p^.registersfpu then
p^.registersfpu:=p^.right^.registersfpu;
{$ifdef SUPPORT_MMX}
if p^.right^.registersmmx>p^.registersmmx then
p^.registersmmx:=p^.right^.registersmmx;
{$endif SUPPORT_MMX}
t_times:=old_t_times;
end;
procedure firstasm(var p : ptree);
begin
{ it's a f... to determine the used registers }
{ should be done by getnode
I think also, that all values should be set to their maximum (FK)
p^.registers32:=0;
p^.registersfpu:=0;
p^.registersmmx:=0;
}
procinfo.flags:=procinfo.flags or pi_uses_asm;
end;
procedure firstgoto(var p : ptree);
begin
{
p^.registers32:=0;
p^.registersfpu:=0;
}
p^.resulttype:=voiddef;
end;
procedure firstlabel(var p : ptree);
begin
cleartempgen;
firstpass(p^.left);
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
p^.resulttype:=voiddef;
end;
procedure firstcase(var p : ptree);
var
old_t_times : longint;
hp : ptree;
begin
{ evalutes the case expression }
cleartempgen;
must_be_valid:=true;
firstpass(p^.left);
if codegenerror then
exit;
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
{ walk through all instructions }
{ estimates the repeat of each instruction }
old_t_times:=t_times;
if not(cs_littlesize in aktswitches ) then
begin
t_times:=t_times div case_count_labels(p^.nodes);
if t_times<1 then
t_times:=1;
end;
{ first case }
hp:=p^.right;
while assigned(hp) do
begin
cleartempgen;
firstpass(hp^.right);
{ searchs max registers }
if hp^.right^.registers32>p^.registers32 then
p^.registers32:=hp^.right^.registers32;
if hp^.right^.registersfpu>p^.registersfpu then
p^.registersfpu:=hp^.right^.registersfpu;
{$ifdef SUPPORT_MMX}
if hp^.right^.registersmmx>p^.registersmmx then
p^.registersmmx:=hp^.right^.registersmmx;
{$endif SUPPORT_MMX}
hp:=hp^.left;
end;
{ may be handle else tree }
if assigned(p^.elseblock) then
begin
cleartempgen;
firstpass(p^.elseblock);
if codegenerror then
exit;
if p^.registers32<p^.elseblock^.registers32 then
p^.registers32:=p^.elseblock^.registers32;
if p^.registersfpu<p^.elseblock^.registersfpu then
p^.registersfpu:=p^.elseblock^.registersfpu;
{$ifdef SUPPORT_MMX}
if p^.registersmmx<p^.elseblock^.registersmmx then
p^.registersmmx:=p^.elseblock^.registersmmx;
{$endif SUPPORT_MMX}
end;
t_times:=old_t_times;
{ there is one register required for the case expression }
if p^.registers32<1 then p^.registers32:=1;
end;
procedure firsttryexcept(var p : ptree);
begin
end;
procedure firsttryfinally(var p : ptree);
begin
end;
procedure firstis(var p : ptree);
begin
firstpass(p^.left);
firstpass(p^.right);
if (p^.right^.resulttype^.deftype<>classrefdef) then
Message(sym_e_type_mismatch);
if codegenerror then
exit;
p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
{$endif SUPPORT_MMX}
{ left must be a class }
if (p^.left^.resulttype^.deftype<>objectdef) or
not(pobjectdef(p^.left^.resulttype)^.isclass) then
Message(sym_e_type_mismatch);
{ the operands must be related }
if (not(pobjectdef(p^.left^.resulttype)^.isrelated(
pobjectdef(pclassrefdef(p^.right^.resulttype)^.definition)))) and
(not(pobjectdef(pclassrefdef(p^.right^.resulttype)^.definition)^.isrelated(
pobjectdef(p^.left^.resulttype)))) then
Message(sym_e_type_mismatch);
p^.location.loc:=LOC_FLAGS;
p^.resulttype:=booldef;
end;
procedure firstas(var p : ptree);
begin
firstpass(p^.right);
firstpass(p^.left);
if (p^.right^.resulttype^.deftype<>classrefdef) then
Message(sym_e_type_mismatch);
if codegenerror then
exit;
p^.registersfpu:=max(p^.left^.registersfpu,p^.left^.registersfpu);
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
{$endif SUPPORT_MMX}
{ left must be a class }
if (p^.left^.resulttype^.deftype<>objectdef) or
not(pobjectdef(p^.left^.resulttype)^.isclass) then
Message(sym_e_type_mismatch);
{ the operands must be related }
if (not(pobjectdef(p^.left^.resulttype)^.isrelated(
pobjectdef(pclassrefdef(p^.right^.resulttype)^.definition)))) and
(not(pobjectdef(pclassrefdef(p^.right^.resulttype)^.definition)^.isrelated(
pobjectdef(p^.left^.resulttype)))) then
Message(sym_e_type_mismatch);
p^.location:=p^.left^.location;
p^.resulttype:=pclassrefdef(p^.right^.resulttype)^.definition;
end;
procedure firstloadvmt(var p : ptree);
begin
{ resulttype must be set !
p^.registersfpu:=0;
}
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end;
procedure firstraise(var p : ptree);
begin
p^.resulttype:=voiddef;
{
p^.registersfpu:=0;
p^.registers32:=0;
}
if assigned(p^.left) then
begin
firstpass(p^.left);
{ this must be a _class_ }
if (p^.left^.resulttype^.deftype<>objectdef) or
((pobjectdef(p^.left^.resulttype)^.options and oois_class)=0) then
Message(sym_e_type_mismatch);
p^.registersfpu:=p^.left^.registersfpu;
p^.registers32:=p^.left^.registers32;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
if assigned(p^.right) then
begin
firstpass(p^.right);
p^.right:=gentypeconvnode(p^.right,s32bitdef);
firstpass(p^.right);
p^.registersfpu:=max(p^.left^.registersfpu,
p^.right^.registersfpu);
p^.registers32:=max(p^.left^.registers32,
p^.right^.registers32);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,
p^.right^.registersmmx);
{$endif SUPPORT_MMX}
end;
end;
end;
procedure firstwith(var p : ptree);
begin
if assigned(p^.left) and assigned(p^.right) then
begin
firstpass(p^.left);
if codegenerror then
exit;
firstpass(p^.right);
if codegenerror then
exit;
p^.registers32:=max(p^.left^.registers32,
p^.right^.registers32);
p^.registersfpu:=max(p^.left^.registersfpu,
p^.right^.registersfpu);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,
p^.right^.registersmmx);
{$endif SUPPORT_MMX}
p^.resulttype:=voiddef;
end
else
begin
{ optimization }
disposetree(p);
p:=nil;
end;
end;
{ procedure firstprocinline(var p : ptree);
var old_inline_proc_firsttemp : longint;
begin
old_inline_proc_firsttemp:=procinfo.firsttemp;
procinfo.firsttemp:=procinfo.firsttemp+p^.inlineproc^.definition^.localst^.datasize;
end; }
type
firstpassproc = procedure(var p : ptree);
procedure firstpass(var p : ptree);
const
procedures : array[ttreetyp] of firstpassproc =
(firstadd,firstadd,firstadd,firstmoddiv,firstadd,
firstmoddiv,firstassignment,firstload,firstrange,
firstadd,firstadd,firstadd,firstadd,
firstadd,firstadd,firstin,firstadd,
firstadd,firstshlshr,firstshlshr,firstadd,
firstadd,firstsubscriptn,firstderef,firstaddr,firstdoubleaddr,
firstordconst,firsttypeconv,firstcalln,firstnothing,
firstrealconst,firstfixconst,firstumminus,firstasm,firstvecn,
firststringconst,firstfuncret,firstselfn,
firstnot,firstinline,firstniln,firsterror,
firsttypen,firsthnewn,firsthdisposen,firstnewn,
firstsimplenewdispose,firstnothing,firstsetcons,firstblock,
firstnothing,firstnothing,firstif,firstnothing,
firstnothing,first_while_repeat,first_while_repeat,firstfor,
firstexitn,firstwith,firstcase,firstlabel,
firstgoto,firstsimplenewdispose,firsttryexcept,firstraise,
firstnothing,firsttryfinally,firstis,firstas,firstadd,
firstnothing,firstnothing,firstloadvmt);
var
oldcodegenerror : boolean;
oldswitches : Tcswitches;
{ there some calls of do_firstpass in the parser }
oldis : pinputfile;
oldnr : longint;
begin
{ if we save there the whole stuff, }
{ line numbers become more correct }
oldis:=current_module^.current_inputfile;
oldnr:=current_module^.current_inputfile^.line_no;
oldcodegenerror:=codegenerror;
oldswitches:=aktswitches;
{$ifdef extdebug}
inc(p^.firstpasscount);
{$endif extdebug}
codegenerror:=false;
current_module^.current_inputfile:=p^.inputfile;
current_module^.current_inputfile^.line_no:=p^.line;
aktswitches:=p^.pragmas;
if not(p^.error) then
begin
procedures[p^.treetype](p);
p^.error:=codegenerror;
codegenerror:=codegenerror or oldcodegenerror;
end
else codegenerror:=true;
aktswitches:=oldswitches;
current_module^.current_inputfile:=oldis;
current_module^.current_inputfile^.line_no:=oldnr;
end;
function do_firstpass(var p : ptree) : boolean;
begin
codegenerror:=false;
firstpass(p);
do_firstpass:=codegenerror;
end;
end.
{
$Log$
Revision 1.2 1998-03-26 11:18:31 florian
- switch -Sa removed
- support of a:=b:=0 removed
Revision 1.1.1.1 1998/03/25 11:18:14 root
* Restored version
Revision 1.41 1998/03/13 22:45:59 florian
* small bug fixes applied
Revision 1.40 1998/03/10 23:48:36 florian
* a couple of bug fixes to get the compiler with -OGaxz compiler, sadly
enough, it doesn't run
Revision 1.39 1998/03/10 16:27:41 pierre
* better line info in stabs debug
* symtabletype and lexlevel separated into two fields of tsymtable
+ ifdef MAKELIB for direct library output, not complete
+ ifdef CHAINPROCSYMS for overloaded seach across units, not fully
working
+ ifdef TESTFUNCRET for setting func result in underfunction, not
working
Revision 1.38 1998/03/10 01:11:11 peter
* removed one of my previous optimizations with string+char, which
generated wrong code
Revision 1.37 1998/03/09 10:44:38 peter
+ string='', string<>'', string:='', string:=char optimizes (the first 2
were already in cg68k2)
Revision 1.36 1998/03/06 00:52:38 peter
* replaced all old messages from errore.msg, only ExtDebug and some
Comment() calls are left
* fixed options.pas
Revision 1.35 1998/03/04 08:38:19 florian
* problem with unary minus fixed
Revision 1.34 1998/03/03 01:08:31 florian
* bug0105 and bug0106 problem solved
Revision 1.33 1998/03/02 01:48:56 peter
* renamed target_DOS to target_GO32V1
+ new verbose system, merged old errors and verbose units into one new
verbose.pas, so errors.pas is obsolete
Revision 1.32 1998/03/01 22:46:14 florian
+ some win95 linking stuff
* a couple of bugs fixed:
bug0055,bug0058,bug0059,bug0064,bug0072,bug0093,bug0095,bug0098
Revision 1.31 1998/02/28 17:26:46 carl
* bugfix #47 and more checking for aprocdef
Revision 1.30 1998/02/13 10:35:20 daniel
* Made Motorola version compilable.
* Fixed optimizer
Revision 1.29 1998/02/12 17:19:16 florian
* fixed to get remake3 work, but needs additional fixes (output, I don't like
also that aktswitches isn't a pointer)
Revision 1.28 1998/02/12 11:50:23 daniel
Yes! Finally! After three retries, my patch!
Changes:
Complete rewrite of psub.pas.
Added support for DLL's.
Compiler requires less memory.
Platform units for each platform.
Revision 1.27 1998/02/11 21:56:34 florian
* bugfixes: bug0093, bug0053, bug0088, bug0087, bug0089
Revision 1.26 1998/02/07 23:05:03 florian
* once more MMX
Revision 1.25 1998/02/07 09:39:24 florian
* correct handling of in_main
+ $D,$T,$X,$V like tp
Revision 1.24 1998/02/06 10:34:21 florian
* bug0082 and bug0084 fixed
Revision 1.23 1998/02/05 21:54:34 florian
+ more MMX
Revision 1.22 1998/02/05 20:54:30 peter
* fixed a Sigsegv
Revision 1.21 1998/02/04 23:04:21 florian
+ unary minus for mmx data types added
Revision 1.20 1998/02/04 22:00:56 florian
+ NOT operator for mmx arrays
Revision 1.19 1998/02/04 14:38:49 florian
* clean up
* a lot of potential bugs removed adding some neccessary register allocations
(FPU!)
+ allocation of MMX registers
Revision 1.18 1998/02/03 23:07:34 florian
* AS and IS do now a correct type checking
+ is_convertable handles now also instances of classes
Revision 1.17 1998/02/01 19:40:51 florian
* clean up
* bug0029 fixed
Revision 1.16 1998/02/01 17:14:04 florian
+ comparsion of class references
Revision 1.15 1998/01/30 21:23:59 carl
* bugfix of compiler crash with new/dispose (fourth crash of new bug)
* bugfix of write/read compiler crash
Revision 1.14 1998/01/25 22:29:00 florian
* a lot bug fixes on the DOM
Revision 1.13 1998/01/21 22:34:25 florian
+ comparsion of Delphi classes
Revision 1.12 1998/01/21 21:29:55 florian
* some fixes for Delphi classes
Revision 1.11 1998/01/16 23:34:13 florian
+ nil is compatible with class variable (tobject(x):=nil)
Revision 1.10 1998/01/16 22:34:40 michael
* Changed 'conversation' to 'conversion'. Waayyy too much chatting going on
in this compiler :)
Revision 1.9 1998/01/13 23:11:10 florian
+ class methods
Revision 1.8 1998/01/07 00:17:01 michael
Restored released version (plus fixes) as current
Revision 1.7 1997/12/10 23:07:26 florian
* bugs fixed: 12,38 (also m68k),39,40,41
+ warning if a system unit is without -Us compiled
+ warning if a method is virtual and private (was an error)
* some indentions changed
+ factor does a better error recovering (omit some crashes)
+ problem with @type(x) removed (crashed the compiler)
Revision 1.6 1997/12/09 13:54:26 carl
+ renamed some stuff (real types mostly)
Revision 1.5 1997/12/04 12:02:19 pierre
+ added a counter of max firstpass's for a ptree
for debugging only in ifdef extdebug
Revision 1.4 1997/12/03 13:53:01 carl
+ ifdef i386.
Revision 1.3 1997/11/29 15:38:43 florian
* bug0033 fixed
* duplicate strings are now really once generated (there was a bug)
Revision 1.2 1997/11/28 11:11:43 pierre
negativ real constants are not supported by nasm assembler
Revision 1.1.1.1 1997/11/27 08:32:59 michael
FPC Compiler CVS start
Pre-CVS log:
CEC Carl-Eric Codere
FK Florian Klaempfl
PM Pierre Muller
+ feature added
- removed
* bug fixed or changed
History:
6th september 1997:
+ added basic support for MC68000 (CEC)
(lines: 189,1860,1884 + ifdef m68k)
19th september 1997:
+ added evalution of constant sets (FK)
+ empty and constant sets are now compatible with all other
set types (FK)
20th september 1997:
* p^.register32 bug in firstcalln (max with register32 of p^.left i.e. args) (PM)
24th september 1997:
* line_no and inputfile are now in firstpass saved (FK)
25th september 1997:
+ support of high for open arrays (FK)
+ the high parameter is now pushed for open arrays (FK)
1th october 1997:
+ added support for unary minus operator and for:=overloading (PM)
2nd october 1997:
+ added handling of in_ord_x (PM)
boolean to byte with ord is special because the location may be different
3rd october 1997:
+ renamed ret_in_eax to ret_in_acc (CEC)
+ find ifdef m68k to find other changes (CEC)
* bugfix or calc correct val for regs. for m68k in firstcalln (CEC)
4th october 1997:
+ added code for in_pred_x in_succ_x
fails for enums with jumps (PM)
25th october 1997:
+ direct evalution of pred and succ with const parameter (FK)
6th november 1997:
* added typeconversion for floatdef in write(ln) for text to s64real (PM)
+ code for str with length arg rewritten (PM)
13th november 1997:
* floatdef in write(ln) for text for different types in RTL (PM)
* bug causing convertability from floatdef to orddef removed (PM)
* typecasting from voiddef to any type not allowed anymore (PM)
+ handling of different real const to diff realtype (PM)
18th november 1997:
* changed first_type_conv function arg as var p : ptree
to be able to change the tree (PM)
}
Reference in New Issue View Git Blame Copy Permalink