{****************************************************************************
Copyright (c) 1996 by Florian Klämpfl
****************************************************************************}
unit pass_1;
interface
uses
objects,cobjects,systems,globals,tree,asmgen,symtable,tempad,
types,strings,i386,hcodegen;
function do_firstpass(var p : ptree) : boolean;
implementation
procedure error(const t : errorconst);
begin
if not(codegenerror) then
globals.error(t);
codegenerror:=true;
end;
procedure firstpass(var p : ptree);forward;
{ markiert einen l-value als nicht in ein Register kopierbar }
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;
{ berechnet für einen binären Operator die benötigten }
{ Register }
procedure calcregisters(p : ptree;r32,fpu : word);
begin
p^.registers32:=p^.left^.registers32;
if p^.right^.registers32>p^.registers32 then
p^.registers32:=p^.right^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
if p^.right^.registersfpu>p^.registersfpu then
p^.registersfpu:=p^.right^.registersfpu;
{ Nur wenn links und rechts ein Unterschied < benötige Anzahl ist, }
{ wird ein zusätzliches Register benö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);
{ Fehlermeldung wenn mehr als 8 FPU-Register benötigt werden }
if p^.registersfpu>8 then error(too_complex_expr);
end;
function both_rm(p : ptree) : boolean;
begin
if ((p^.left^.location.loc=LOC_MEM) or
(p^.left^.location.loc=LOC_REFERENZ))
and ((p^.right^.location.loc=LOC_MEM) or
(p^.right^.location.loc=LOC_REFERENZ)) then
both_rm:=true else both_rm:=false;
end;
function isconvertable(def_from,def_to : pdef;var doconv : tconverttype;fromtreetype : ttreetyp) : boolean;
{ from_is_cstring muß true sein, wenn def_from die Definition einer }
{ Stringkonstanten ist, nötig wegen der Konvertierung von String- }
{ konstante zu nullterminiertem String }
{ Hilfsliste: u8bit,s32bit,s64real,uvoid,
bool8bit,uchar,s8bit,s16bit,u16bit }
const
grunddefconverts : array[u8bit..u16bit,u8bit..u16bit] of tconverttype =
((tc_equal,tc_u8bit_2_s32bit,tc_int_2_real,tc_not_possible,
tc_not_possible,tc_not_possible,tc_equal,tc_u8bit_2_s16bit,tc_u8bit_2_u16bit),
(tc_s32bit_2_u8bit,tc_equal,tc_int_2_real,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_not_possible,tc_equal,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,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,tc_not_possible,
tc_equal,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,tc_equal,tc_not_possible,tc_not_possible,tc_not_possible),
(tc_equal,tc_s8bit_2_s32bit,tc_int_2_real,tc_not_possible,
tc_not_possible,tc_not_possible,tc_equal,tc_s8bit_2_s16bit,tc_s8bit_2_u16bit),
(tc_s16bit_2_u8bit,tc_s16bit_2_s32bit,tc_int_2_real,tc_not_possible,
tc_not_possible,tc_not_possible,tc_s16bit_2_s8bit,tc_equal,tc_equal),
(tc_u16bit_2_u8bit,tc_u16bit_2_s32bit,tc_int_2_real,tc_not_possible,
tc_not_possible,tc_not_possible,tc_u16bit_2_s8bit,tc_equal,tc_equal));
var
b : boolean;
begin
b:=false;
if (def_from^.deftype=grunddef) and (def_to^.deftype=grunddef) then
begin
doconv:=grunddefconverts[pgrunddef(def_from)^.typ,pgrunddef(def_to)^.typ];
if doconv<>tc_not_possible then
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
{ Kindklassenzeiger kann an Elternklassenzeigertyp zugewiesen werden }
else if (def_from^.deftype=pointerdef) and (def_to^.deftype=pointerdef) and
(ppointerdef(def_from)^.definition^.deftype=classdef) and
(ppointerdef(def_to)^.definition^.deftype=classdef) and
pclassdef(ppointerdef(def_from)^.definition)^.isrelated(
pclassdef(ppointerdef(def_to)^.definition)) then
begin
doconv:=tc_equal;
b:=true;
end
{ Prozedurvariable kann an void-Pointer zugewiesen werden }
else if (def_from^.deftype=procvardef) and
(def_to^.deftype=pointerdef) and
(ppointerdef(def_to)^.definition^.deftype=grunddef) and
(pgrunddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
begin
doconv:=tc_equal;
b:=true;
end
else
if (def_from^.deftype=stringdef) and (def_to^.deftype=stringdef) then
begin
doconv:=tc_string_to_string;
b:=true;
end
else
{ Char nach String: }
if (def_from^.deftype=grunddef) and
(pgrunddef(def_from)^.typ=uchar) and
(def_to^.deftype=stringdef) then
begin
doconv:=tc_char_to_string;
b:=true;
end
else
{ Stringkonstante zu nullterm. Stringkonstante }
if (fromtreetype=stringconstn) and
(
(def_to^.deftype=pointerdef) and
(ppointerdef(def_to)^.definition^.deftype=grunddef) and
(pgrunddef(ppointerdef(def_to)^.definition)^.typ=uchar)
)
then
begin
doconv:=tc_cstring_charpointer;
b:=true;
end
else
if (fromtreetype=stringconstn) and
(
(def_to^.deftype=arraydef) and (parraydef(def_to)^.lowrange=0) and
(parraydef(def_to)^.definition^.deftype=grunddef) and
(pgrunddef(parraydef(def_to)^.definition)^.typ=uchar)
)
then
begin
doconv:=tc_cstring_chararray;
b:=true;
end
else
if (fromtreetype=ordconstn) and (def_from^.deftype=grunddef) and
(pgrunddef(def_from)^.typ=uchar) and
(
(def_to^.deftype=arraydef) and (parraydef(def_to)^.lowrange=0) and
(parraydef(def_to)^.definition^.deftype=grunddef) and
(pgrunddef(parraydef(def_to)^.definition)^.typ=uchar)
)
then
begin
doconv:=tc_cchar_chararray;
b:=true;
end;
isconvertable:=b;
end;
procedure firsterror(var p : ptree);far;
begin
p^.error:=true;
codegenerror:=true;
end;
procedure firstload(var p : ptree);far;
begin
p^.location.loc:=LOC_REFERENZ;
p^.registers32:=0;
p^.registersfpu:=0;
clear_referenz(p^.location.referenz);
case p^.symtableentry^.typ of
varsym :
begin
p^.resulttype:=pvarsym(p^.symtableentry)^.definition;
if ((p^.symtable^.symtabletype and $c000)<>0) and
(lexlevel>(p^.symtable^.symtabletype and $3fff)) then
begin
{ sollte sich die Variable in einem anderen Stackframe }
{ befinden, so brauchen wir ein Register zum Dereferenzieren }
if (p^.symtable^.symtabletype and $3fff)<>0 then
begin
p^.registers32:=1;
{ auß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;
{ Bei einem Call by Referenz brauchen wir ein Register }
if (pvarsym(p^.symtableentry)^.varspez=vs_var) or
((pvarsym(p^.symtableentry)^.varspez=vs_const) and
(
(pvarsym(p^.symtableentry)^.definition^.deftype=stringdef) or
(pvarsym(p^.symtableentry)^.definition^.deftype=arraydef) or
(pvarsym(p^.symtableentry)^.definition^.deftype=recorddef) or
(pvarsym(p^.symtableentry)^.definition^.deftype=classdef) or
(pvarsym(p^.symtableentry)^.definition^.deftype=setdef)
)
) then
p^.registers32:=1;
if p^.symtable^.symtabletype=withsymtable then
p^.registers32:=1;
{ Referenzen für eine Variable zählen }
if t_times<1 then
inc(pvarsym(p^.symtableentry)^.refs)
else
inc(pvarsym(p^.symtableentry)^.refs,t_times);
end;
typedconstsym :
p^.resulttype:=ptypedconstsym(p^.symtableentry)^.definition;
procsym :
begin
if assigned(pprocsym(p^.symtableentry)^.definition^.nextoverloaded) then
error(no_overloaded_procvars);
p^.resulttype:=pprocsym(p^.symtableentry)^.definition;
end;
else internalerror(3);
end;
end;
{ müßten eigentlich lokal sein, belasten aber den Stack zu stark }
var
s1,s2 : string;
procedure firstadd(var p : ptree);far;
var
lt,rt : ttreetyp;
t : ptree;
rv,lv : longint;
rvd,lvd : double;
rd,ld : pdef;
concatstrings : boolean;
label
no_overload;
begin
{ erst die beiden Äste bearbeiten }
firstpass(p^.left);
firstpass(p^.right);
if codegenerror then
exit;
{ overloaded operator ? }
if (p^.left^.resulttype^.deftype=recorddef) or
(p^.left^.resulttype^.deftype=classdef) or
(p^.left^.resulttype^.deftype=recorddef) or
(p^.left^.resulttype^.deftype=classdef) 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[0],nil);
else goto no_overload;
end;
firstpass(p);
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);
else
error(type_mismatch);
end;
disposetree(p);
p:=t;
exit;
end
else
{ Realkonstanten: }
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);
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
error(type_mismatch);
end;
disposetree(p);
p:=t;
firstpass(p);
exit;
end;
concatstrings:=false;
if (lt=ordconstn) and (rt=ordconstn) and
(p^.left^.resulttype^.deftype=grunddef) and
(pgrunddef(p^.left^.resulttype)^.typ=uchar) and
(p^.right^.resulttype^.deftype=grunddef) and
(pgrunddef(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=grunddef) and
(pgrunddef(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=grunddef) and
(pgrunddef(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(ord(s1<s2),booldef);
lten : t:=genordinalconstnode(ord(s1<=s2),booldef);
gtn : t:=genordinalconstnode(ord(s1>s2),booldef);
gten : t:=genordinalconstnode(ord(s1>=s2),booldef);
equaln : t:=genordinalconstnode(ord(s1=s2),booldef);
unequaln : t:=genordinalconstnode(ord(s1<>s2),booldef);
end;
disposetree(p);
p:=t;
exit;
end;
rd:=p^.right^.resulttype;
ld:=p^.left^.resulttype;
{ wenn beides Boolean: }
if ((ld^.deftype=grunddef) and
(pgrunddef(ld)^.typ=bool8bit)) and
((rd^.deftype=grunddef) and
(pgrunddef(rd)^.typ=bool8bit)) then
begin
if (p^.treetype=andn) or (p^.treetype=orn) then
begin
calcregisters(p,0,0);
p^.location.loc:=LOC_JUMP;
end
else if (p^.treetype=unequaln) or (p^.treetype=equaln) then
begin
calcregisters(p,1,0);
p^.location.loc:=LOC_FLAGS;
p^.resulttype:=booldef;
end
else error(type_mismatch);
end
{ wenn beides vom Char dann keine Konvertiereung einfügen }
{ höchstens es handelt sich um einen +-Operator }
else if ((rd^.deftype=grunddef) and (pgrunddef(rd)^.typ=uchar)) and
((ld^.deftype=grunddef) and (pgrunddef(ld)^.typ=uchar)) then
begin
if p^.treetype=addn then
begin
p^.right:=gentypeconvnode(p^.right,cstringdef);
p^.left:=gentypeconvnode(p^.left,cstringdef);
firstpass(p^.left);
firstpass(p^.right);
calcregisters(p,0,0);
p^.location.loc:=LOC_MEM;
end
else
calcregisters(p,1,0);
end
{ wenn links String und rechts Char, dann Char konvertieren }
else if ((rd^.deftype=stringdef) and
((ld^.deftype=grunddef) and (pgrunddef(ld)^.typ=uchar))) or
((ld^.deftype=stringdef) and
((rd^.deftype=grunddef) and (pgrunddef(rd)^.typ=uchar))) then
begin
if ((rd^.deftype=grunddef) and (pgrunddef(rd)^.typ=uchar)) then
p^.right:=gentypeconvnode(p^.right,cstringdef)
else p^.left:=gentypeconvnode(p^.left,cstringdef);
firstpass(p^.left);
firstpass(p^.right);
calcregisters(p,0,0);
p^.location.loc:=LOC_MEM;
end
else
if ((rd^.deftype=setdef) and (ld^.deftype=setdef)) then
begin
if not(is_equal(psetdef(rd)^.setof,psetdef(ld)^.setof)) then
error(set_element_are_not_comp);
firstpass(p^.left);
firstpass(p^.right);
calcregisters(p,0,0);
p^.location.loc:=LOC_MEM;
end
else
if ((rd^.deftype=stringdef) and (ld^.deftype=stringdef)) then
{ nichts tun, ist aber OK }
{ sollte eine Realzahl dabei sein, beide nach s64bitreal konvertieren }
else
if ((rd^.deftype=grunddef) and (pgrunddef(rd)^.typ=s64real)) or
((ld^.deftype=grunddef) and (pgrunddef(ld)^.typ=s64real)) then
begin
p^.right:=gentypeconvnode(p^.right,cs64realdef);
p^.left:=gentypeconvnode(p^.left,cs64realdef);
firstpass(p^.left);
firstpass(p^.right);
calcregisters(p,0,1);
p^.location.loc:=LOC_FPUSTACK;
end
{ Pointervergleiche und Subtraktion: }
else if (rd^.deftype=pointerdef) and (ld^.deftype=pointerdef) and
is_equal(rd,ld) then
begin
calcregisters(p,1,0);
p^.location.loc:=LOC_REGISTER;
case p^.treetype of
equaln,unequaln : ;
ltn,lten,gtn,gten : begin
if aktexprlevel<1 then
error(type_mismatch);
end;
subn : begin
if aktexprlevel<1 then
error(type_mismatch);
p^.resulttype:=s32bitdef;
exit;
end;
else error(type_mismatch);
end;
end
else if (rd^.deftype=procvardef) and (ld^.deftype=procvardef) and
is_equal(rd,ld) then
begin
calcregisters(p,1,0);
p^.location.loc:=LOC_REGISTER;
case p^.treetype of
equaln,unequaln : ;
else error(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);
if p^.treetype=addn then
begin
if aktexprlevel<1 then
error(type_mismatch);
end
else error(type_mismatch);
end
else if (ld^.deftype=aufzaehldef) and (rd^.deftype=aufzaehldef)
and (is_equal(ld,rd)) then
begin
calcregisters(p,1,0);
case p^.treetype of
equaln,unequaln,
ltn,lten,gtn,gten : ;
else error(type_mismatch);
end;
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);
case p^.treetype of
addn,subn : if aktexprlevel<1 then
error(type_mismatch);
else error(type_mismatch);
end;
end
{ sonst immer nach 32 Bit-Int konvertieren }
else
begin
p^.right:=gentypeconvnode(p^.right,s32bitdef);
p^.left:=gentypeconvnode(p^.left,s32bitdef);
firstpass(p^.left);
firstpass(p^.right);
calcregisters(p,1,0);
p^.location.loc:=LOC_REGISTER;
end;
if codegenerror then
exit;
{ Resultatyp feststellen; bei Vergleich Boolean }
case p^.treetype of
ltn,lten,gtn,gten,equaln,unequaln : begin
p^.resulttype:=booldef;
p^.location.loc:=LOC_FLAGS;
end;
addn : begin
{ Stringaddition hat eine String von 255 Zeichen }
{ Länge als Ergebnis }
if (p^.left^.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);far;
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;
p^.right:=gentypeconvnode(p^.right,s32bitdef);
p^.left:=gentypeconvnode(p^.left,s32bitdef);
firstpass(p^.left);
firstpass(p^.right);
if codegenerror then
exit;
p^.registers32:=p^.left^.registers32;
if p^.registers32<p^.right^.registers32 then
p^.registers32:=p^.right^.registers32;
if p^.registers32<2 then p^.registers32:=2;
p^.resulttype:=s32bitdef;
p^.location.loc:=LOC_REGISTER;
end;
procedure firstshlshr(var p : ptree);far;
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);
{
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);far;
begin
p^.location.loc:=LOC_MEM;
end;
procedure firstordconst(var p : ptree);far;
begin
p^.location.loc:=LOC_MEM;
end;
procedure firstniln(var p : ptree);far;
begin
p^.resulttype:=voidpointerdef;
p^.location.loc:=LOC_MEM;
end;
procedure firststringconst(var p : ptree);far;
begin
p^.resulttype:=new(pstringdef,init(length(p^.values^)));
p^.location.loc:=LOC_MEM;
end;
procedure firstumminus(var p : ptree);far;
var
t : ptree;
begin
firstpass(p^.left);
if codegenerror then
exit;
if is_constintnode(p^.left) then
begin
t:=genordinalconstnode(-p^.left^.value,s32bitdef);
disposetree(p);
p:=t;
exit;
end;
if (p^.left^.resulttype^.deftype=grunddef) then
begin
if pgrunddef(p^.left^.resulttype)^.typ=s64real then
begin
p^.location.loc:=LOC_FPUSTACK;
end
else
begin
p^.left:=gentypeconvnode(p^.left,s32bitdef);
firstpass(p^.left);
if codegenerror then
exit;
if (p^.left^.location.loc<>LOC_REGISTER) and
(p^.registers32<1) then
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end;
end
else
error(type_mismatch);
p^.registers32:=p^.left^.registers32;
p^.resulttype:=p^.left^.resulttype;
end;
procedure firstaddr(var p : ptree);far;
var
hp : ptree;
hp2 : pdefcoll;
begin
make_not_regable(p^.left);
if not(assigned(p^.resulttype)) then
begin
{ falls Adresse von einer Callnode bestimmt werden soll, }
{ die Callnode in eine Loadnode umwandeln }
if p^.left^.treetype=calln then
begin
hp:=genloadnode(pvarsym(p^.left^.symtableprocentry),p^.left^.symtableproc);
{ Resultat ist eine Prozedurvariable }
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;
disposetree(p^.left);
p^.left:=hp;
end
else
begin
if aktexprlevel<2 then
p^.resulttype:=voidpointerdef
else p^.resulttype:=new(ppointerdef,init(p^.left^.resulttype));
end;
end;
firstpass(p^.left);
if codegenerror then
exit;
if (p^.left^.location.loc<>LOC_REFERENZ) then
error(error_in_expression);
p^.registers32:=p^.left^.registers32;
if p^.registers32<1 then
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end;
procedure firstnot(var p : ptree);far;
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;
if (p^.resulttype^.deftype=grunddef) and
(pgrunddef(p^.resulttype)^.typ=bool8bit) then
begin
p^.registers32:=p^.left^.registers32;
if (p^.location.loc=LOC_REFERENZ) and
(p^.registers32<1) then
p^.registers32:=1;
end
else
begin
p^.left:=gentypeconvnode(p^.left,s32bitdef);
firstpass(p^.left);
if codegenerror then
exit;
p^.resulttype:=p^.left^.resulttype;
p^.registers32:=p^.left^.registers32;
if (p^.left^.location.loc<>LOC_REGISTER) and
(p^.registers32<1) then
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end;
end;
procedure firstnothing(var p : ptree);far;
begin
end;
procedure firstassignment(var p : ptree);far;
begin
firstpass(p^.left);
firstpass(p^.right);
if codegenerror then
exit;
{ sollte rechts und links ein String stehen, muß nicht konvertiert }
{ werden, da STRCOPY mit den richtigen Parametern aufgerufen wird }
if not((p^.right^.resulttype^.deftype=stringdef)
and (p^.left^.resulttype^.deftype=stringdef)) then
begin
p^.right:=gentypeconvnode(p^.right,p^.left^.resulttype);
{ nochmal firstpass wegen der Typkonvertierung aufrufen }
firstpass(p^.right);
if codegenerror then
exit;
end;
if (aktexprlevel<4) then p^.resulttype:=voiddef
else p^.resulttype:=p^.right^.resulttype;
{
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);
end;
procedure firstlr(var p : ptree);far;
begin
firstpass(p^.left);
firstpass(p^.right);
end;
procedure firstderef(var p : ptree);far;
begin
firstpass(p^.left);
if codegenerror then
exit;
p^.registers32:=p^.left^.registers32;
if p^.registers32<1 then
p^.registers32:=1;
if p^.left^.resulttype^.deftype<>pointerdef then
error(invalid_qualifizier);
p^.resulttype:=ppointerdef(p^.left^.resulttype)^.definition;
p^.location.loc:=LOC_REFERENZ;
end;
procedure firstrange(var p : ptree);far;
var
ct : tconverttype;
begin
firstpass(p^.left);
firstpass(p^.right);
if codegenerror then
exit;
{ nur ordinale Konstanten zulassen }
if not((p^.left^.treetype=ordconstn) and
(p^.right^.treetype=ordconstn)) then
error(error_in_expression);
{ Obergrenze muß größer oder gleich Untergrenze sein }
if (p^.left^.value>p^.right^.value) then
error(upper_l_lower);
{ beide Typen müssen kompatibel sein }
if not(isconvertable(p^.left^.resulttype,p^.right^.resulttype,
ct,ordconstn { nur Dummy} )) and
not(is_equal(p^.left^.resulttype,p^.right^.resulttype)) then
error(type_mismatch);
end;
procedure firstvecn(var p : ptree);far;
var
harr : pdef;
ct : tconverttype;
begin
firstpass(p^.left);
firstpass(p^.right);
if codegenerror then
exit;
{ nur bei Arraysindex testen }
if (p^.left^.resulttype^.deftype=arraydef) then
begin
if not(isconvertable(p^.right^.resulttype,
parraydef(p^.left^.resulttype)^.rangedef,
ct,ordconstn { only dummy} )) and
not(is_equal(p^.right^.resulttype,
parraydef(p^.left^.resulttype)^.rangedef)) then
error(type_mismatch);
end;
{ maybe type conversation }
if p^.right^.resulttype^.deftype<>aufzaehldef then
p^.right:=gentypeconvnode(p^.right,s32bitdef);
{ nochmal firstpass }
firstpass(p^.right);
if codegenerror then
exit;
{ Returntyp berechnen }
if p^.left^.resulttype^.deftype=arraydef then
p^.resulttype:=parraydef(p^.left^.resulttype)^.definition
else if (p^.left^.resulttype^.deftype=pointerdef) then
begin
{ Pointer in Array umwandeln }
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
{ indizierter Zugriff auf String }
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
{ mindestens ein Register }
p^.registers32:=max(p^.registers32,1);
end;
{ es wird derselbe Speichertyp wie links zurückgegeben }
p^.location.loc:=p^.left^.location.loc;
end;
type
tfirstconvproc = procedure(p : ptree);
procedure first_bigger_smaller(p : ptree);far;
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(p : ptree);far;
begin
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end;
procedure first_cstring_chararray(p : ptree);far;
begin
p^.location.loc:=LOC_MEM;
end;
procedure first_string_string(p : ptree);far;
begin
p^.location.loc:=LOC_MEM;
end;
procedure first_char_to_string(p : ptree);far;
begin
p^.location.loc:=LOC_MEM;
end;
procedure first_nothing(p : ptree);far;
begin
end;
procedure first_array_to_pointer(p : ptree);far;
begin
if p^.registers32<1 then
p^.registers32:=1;
p^.location.loc:=LOC_REGISTER;
end;
procedure first_int_real(p : ptree);far;
begin
if p^.left^.treetype=ordconstn then
begin
{ Konstanten direkt umwandeln }
p^.treetype:=realconstn;
p^.labnumber:=-1;
p^.valued:=p^.left^.value;
p^.disposetyp:=dt_nothing;
disposetree(p^.left);
p^.location.loc:=LOC_MEM;
end
else
begin
inc(p^.registersfpu);
p^.location.loc:=LOC_FPUSTACK;
end;
end;
procedure first_pointer_to_array(p : ptree);far;
begin
if p^.registers32<1 then
p^.registers32:=1;
p^.location.loc:=LOC_REFERENZ;
end;
{ Achtung: *** kein *** rekursiver Aufruf von firstpass }
procedure firsttypeconv(var p : ptree);far;
var
hp : ptree;
const
firstconvert : array[tc_u8bit_2_s32bit..tc_int_2_real] 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_string_string,
first_cstring_charpointer,first_cstring_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_int_real);
begin
{ bei expliziten Typkonvertierungen firstpass ausführen }
if p^.explizit then
firstpass(p^.left);
if codegenerror then
exit;
{ Typekonvertierungen auf sich selbst entfernen }
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;
p^.location:=p^.left^.location;
if not(isconvertable(p^.left^.resulttype,p^.resulttype,p^.convtyp,p^.left^.treetype)) then
begin
if p^.explizit then
begin
{ normal tc_equal-Konvertierung durchführen }
p^.convtyp:=tc_equal;
{ wenn Aufzähltyp nach Ordinal konvertiert werden soll }
{ dann Aufzähltyp=s32bit }
if (p^.left^.resulttype^.deftype=aufzaehldef) 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
error(ill_type_cast);
end;
end
{ entsprechend Ordinal nach Aufzähl: }
else if (p^.resulttype^.deftype=aufzaehldef) 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
error(ill_type_cast);
end;
end
{ nur wenn gleiche Größe }
else if (p^.left^.resulttype^.deftype<>formaldef) and
(p^.left^.resulttype^.size<>p^.resulttype^.size) then
error(ill_type_cast);
{ und nach strukturierten Typen nur, }
{ wenn die Quelle nicht ein Register ist }
case p^.resulttype^.deftype of
recorddef,stringdef,arraydef,classdef :
if (p^.left^.location.loc=LOC_REGISTER) or
(p^.left^.location.loc=LOC_CREGISTER) then
error(ill_type_cast);
end;
end
else
error(type_mismatch);
end
else
begin
p^.explizit:=false;
{ ordinale Konstanten direkt konvertieren }
if (p^.left^.treetype=ordconstn) and is_ordinal(p^.resulttype) then
begin
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;
{ *************** Funktionshandling **************** }
procedure firstcallparan(var p : ptree;defcoll : pdefcoll);
begin
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;
end;
if defcoll=nil then
begin
firstpass(p^.left);
if codegenerror then
exit;
p^.resulttype:=p^.left^.resulttype;
end
{ falls aufzurufendes Unterprogramm schon bekannt, dann }
{ Typkonvertierungen einfügen }
else
begin
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
not(is_equal(p^.left^.resulttype,defcoll^.data)) then
begin
error(call_by_ref_without_typeconv);
exit;
end;
p^.left:=gentypeconvnode(p^.left,defcoll^.data);
firstpass(p^.left);
if codegenerror then
exit;
end;
{ Variablen, die call by referenz übergeben werden, }
{ können nicht in ein Register kopiert werden }
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;
end;
procedure firstcalln(var p : ptree);far;
type
pprocdefcoll = ^tprocdefcoll;
tprocdefcoll = record
data : pprocdef;
nextpara : pdefcoll;
next : pprocdefcoll;
end;
var
hp,procs,hp2 : pprocdefcoll;
pd : pprocdef;
pt : ptree;
exactmatch : boolean;
paralength,l : longint;
pdc : pdefcoll;
{ nur ein Dummy }
hcvt : tconverttype;
{ types.is_euqal darf keine formaldef's behandeln !}
function is_equal(def1,def2 : pdef) : boolean;
begin
{ alle Typen können an formaldef übergeben werden }
is_equal:=(def1^.deftype=formaldef) or
types.is_equal(def1,def2);
end;
begin
{ Register freigeben! }
{ falls procdefinition<>nil, dann wurde schon firstpass }
{ aufgerufen }
{ scheint nicht so gut wegen der Register }
{ if assigned(p^.procdefinition) then
exit; }
{ handelt es sich um eine Prozedurvariable ? }
if not(assigned(p^.right)) then
begin
if assigned(p^.left) then
begin
firstcallparan(p^.left,nil);
if codegenerror then
exit;
end;
{ Länge der Parameterliste feststellen }
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ügen }
pd:=p^.symtableprocentry^.definition;
procs:=nil;
while assigned(pd) do
begin
{ Laenge der deklarierten Parameterliste feststellen: }
pdc:=pd^.para1;
l:=0;
while assigned(pdc) do
begin
inc(l);
pdc:=pdc^.next;
end;
{ nur wenn die Parameterlänge paßt, dann Einfügen }
if l=paralength then
begin
new(hp);
hp^.data:=pd;
hp^.next:=procs;
hp^.nextpara:=pd^.para1;
procs:=hp;
end;
pd:=pd^.nextoverloaded;
end;
{ nun alle Parameter nacheinander vergleichen }
pt:=p^.left;
while assigned(pt) do
begin
{ paßt der Parameter irgendwo exakt? }
exactmatch:=false;
hp:=procs;
while assigned(hp) do
begin
if is_equal(hp^.nextpara^.data,pt^.resulttype) then
exactmatch:=true;
hp:=hp^.next;
end;
{ ja, dann alle anderen Prozeduren entfernen }
if exactmatch then
begin
{ erst am Anfang }
while (assigned(procs)) and not(is_equal(procs^.nextpara^.data,pt^.resulttype)) 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(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 setzten }
hp:=procs;
while assigned(hp) do
begin
hp^.nextpara:=hp^.nextpara^.next;
hp:=hp^.next;
end;
pt:=pt^.right;
end;
if procs=nil then
begin
error(no_para_match);
exit;
end;
if assigned(procs^.next) then
error(too_much_matches);
p^.procdefinition:=procs^.data;
p^.resulttype:=procs^.data^.retdef;
p^.location.loc:=LOC_MEM;
{ nochmal die Parameter beackern, um die Typkonvertiereungen }
{ einbauen zu koennen }
if assigned(p^.left) then
firstcallparan(p^.left,p^.procdefinition^.para1);
{ interne Proceduren bearbeiten }
if (p^.procdefinition^.options and pointernproc)<>0 then
begin
pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,p^.left^.left);
if assigned(p^.left^.right) then
disposetree(p^.left^.right);
putnode(p^.left);
putnode(p);
firstpass(pt);
if codegenerror then
exit;
p:=pt;
exit;
end;
end
else
begin
{ Prozedurvariable }
{ die Typen der Parameter berechnen }
if assigned(p^.left) then
begin
firstcallparan(p^.left,nil);
if codegenerror then
exit;
end;
firstpass(p^.right);
{ Parameter überprüfen }
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
error(no_para_match);
{ Typkonvertierungen einbauen }
if assigned(p^.left) then
begin
firstcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1);
if codegenerror then
exit;
end;
p^.resulttype:=pprocvardef(p^.right^.resulttype)^.retdef;
end;
{ und falls noetig ein Register fuer den Returnwert bereitstellen }
if (p^.resulttype<>pdef(voiddef)) then
begin
{ Konstruktor meldet sich über die Flags }
if (p^.procdefinition^.options and poconstructor)<>0 then
p^.location.loc:=LOC_FLAGS
else
begin
p^.location.loc:=LOC_REGISTER;
if ((p^.resulttype^.deftype=procvardef) or
(p^.resulttype^.deftype=aufzaehldef) or
(p^.resulttype^.deftype=pointerdef)) then
p^.registers32:=1
else if (p^.resulttype^.deftype=grunddef) then
begin
if pgrunddef(p^.resulttype)^.typ=s64real then
begin
p^.registersfpu:=1;
p^.location.loc:=LOC_FPUSTACK;
end
else p^.registers32:=1
end;
end;
end;
{ noch falls nötig Classpointer berechen }
{ aber nur wenn dieser kein "Hilfsknoten" ist }
if (p^.methodpointer<>nil) then
begin
case p^.methodpointer^.treetype of
typen,hnewn : ;
else
begin
firstpass(p^.methodpointer);
p^.registersfpu:=max(p^.methodpointer^.registersfpu,p^.registersfpu);
p^.registers32:=max(p^.methodpointer^.registers32,p^.registers32);
end;
end;
end;
{ Die benutzten Register der Prozedurvariable berücksichtigen }
if assigned(p^.right) then
begin
p^.registersfpu:=max(p^.right^.registersfpu,p^.registersfpu);
p^.registers32:=max(p^.right^.registers32,p^.registers32);
end;
end;
procedure firstfuncret(var p : ptree);far;
begin
p^.resulttype:=procinfo.retdef;
p^.location.loc:=LOC_REFERENZ;
if (procinfo.retdef^.deftype=arraydef) or
(procinfo.retdef^.deftype=stringdef) or
(procinfo.retdef^.deftype=recorddef) or
(procinfo.retdef^.deftype=classdef) or
(procinfo.retdef^.deftype=setdef) then
p^.registers32:=1;
end;
{ interne Inlineprozeduren }
procedure firstinline(var p : ptree);far;
var
hp : ptree;
isreal : boolean;
begin
{ bei writeln; enthält p^.left keine gültige Adresse }
if assigned(p^.left) then
begin
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
p^.location:=p^.left^.location;
end;
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^.resulttype:=voidpointerdef;
p^.location.loc:=LOC_REGISTER;
end;
in_ord_char : begin
p^.resulttype:=u8bitdef;
{ Konstanten direkt umwandeln }
if p^.left^.treetype=ordconstn then
begin
hp:=p^.left;
putnode(p);
hp^.resulttype:=s32bitdef;
p:=hp;
end;
end;
in_chr_byte : begin
p^.resulttype:=cchardef;
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;
end;
in_assigned_x : begin
p^.resulttype:=booldef;
p^.location.loc:=LOC_FLAGS;
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_REFERENZ then
error(error_in_expression);
end;
in_read_x,
in_readln_x,
in_write_x,
in_writeln_x : begin
p^.resulttype:=voiddef;
if assigned(p^.left) then
begin
firstcallparan(p^.left,nil);
{ Typkonvertierungen für write(ln) einfügen }
if (p^.inlinenumber=in_write_x) or (p^.inlinenumber=in_writeln_x) then
begin
hp:=p^.left;
while assigned(hp) do
begin
if hp^.left^.resulttype^.deftype=grunddef then
case pgrunddef(hp^.left^.resulttype)^.typ of
u8bit,s8bit,
u16bit,s16bit :
hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
end;
hp:=hp^.right;
end;
end;
{ nochmals alle Parameter bearbeiten }
firstcallparan(p^.left,nil);
end;
end;
in_str_x_string : begin
p^.resulttype:=voiddef;
if assigned(p^.left) then
begin
firstcallparan(p^.left,nil);
hp:=p^.left;
if hp^.resulttype^.deftype=grunddef then
begin
isreal:=false;
{ ersten Parameter konvertieren }
{ und natürlich Gültigkeit prüfen }
case pgrunddef(hp^.left^.resulttype)^.typ of
s64real : isreal:=true;
u8bit,s8bit,
u16bit,s16bit :
hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
else error(no_para_match);
end;
{ nächster Parameter }
hp:=hp^.right;
{ Formatieroptionen ?}
if hp^.left^.is_colon_para then
hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
hp:=hp^.right;
if hp^.left^.is_colon_para then
begin
if isreal then
hp^.left:=gentypeconvnode(hp^.left,s32bitdef)
else error(ill_colon_qualifier);
hp:=hp^.right;
end;
{ gültiger String ? }
if (hp^.left^.resulttype^.deftype<>stringdef) or
(hp^.left^.location.loc<>LOC_REFERENZ) then
error(error_in_expression);
{ !!!!! Länge von String überprüfen }
{ nochmals alle Parameter bearbeiten }
firstcallparan(p^.left,nil);
end
else error(error_in_expression);
end
else error(error_in_expression);
end;
else internalerror(8);
end;
end;
procedure firstsubscriptn(var p : ptree);far;
begin
firstpass(p^.left);
if codegenerror then
exit;
if (p^.left^.location.loc<>LOC_MEM) and
(p^.left^.location.loc<>LOC_REFERENZ) then
error(error_in_expression);
p^.resulttype:=p^.vs^.definition;
p^.location:=p^.left^.location;
p^.registers32:=p^.left^.registers32;
end;
procedure firstselfn(var p : ptree);far;
begin
p^.location.loc:=LOC_REFERENZ;
end;
procedure firsttypen(var p : ptree);far;
begin
error(typeid_here_not_allowed);
end;
procedure firsthnewn(var p : ptree);far;
begin
end;
procedure firsthdisposen(var p : ptree);far;
begin
{ Standardeinleitung }
firstpass(p^.left);
if codegenerror then
exit;
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
if p^.registers32<1 then
p^.registers32:=1;
{
if p^.left^.location.loc<>LOC_REFERENZ then
error(error_in_expression);
}
p^.location.loc:=LOC_REFERENZ;
p^.resulttype:=ppointerdef(p^.left^.resulttype)^.definition;
end;
procedure firstnewn(var p : ptree);far;
begin
{ Standardeinleitung }
firstpass(p^.left);
{
unnötig da nichts Weltbewegendes danach geschieht }
if codegenerror then
exit;
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{ Resultattyp ist schon gesetzt }
p^.location.loc:=LOC_REGISTER;
end;
procedure firstsimplenewdispose(var p : ptree);far;
begin
{ no special "effects" }
firstpass(p^.left);
{ check the type }
if p^.left^.resulttype^.deftype<>pointerdef then
error(pointer_expect);
if (p^.left^.location.loc<>LOC_REFERENZ) and
(p^.left^.location.loc<>LOC_CREGISTER) then
error(error_in_expression);
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
p^.resulttype:=voiddef;
end;
procedure firstsetcons(var p : ptree);far;
var
hp : ptree;
begin
p^.location.loc:=LOC_MEM;
hp:=p^.left;
p^.registers32:=0;
p^.registersfpu:=0;
while hp<>nil do
begin
firstpass(hp^.left);
if codegenerror then
exit;
p^.registers32:=max(p^.registers32,p^.left^.registers32);
p^.registersfpu:=max(p^.registersfpu,p^.left^.registersfpu);;
hp:=hp^.right;
end;
{ Resulttattyp ist schon gesetzt }
end;
procedure firstin(var p : ptree);far;
begin
p^.location.loc:=LOC_FLAGS;
p^.resulttype:=booldef;
firstpass(p^.right);
if codegenerror then
exit;
if p^.right^.resulttype^.deftype<>setdef then
error(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);
end;
{ !!!!!!!!!!!! unused }
procedure firstexpr(var p : ptree);far;
begin
firstpass(p^.left);
if codegenerror then
exit;
p^.registers32:=p^.left^.registers32;
if (aktexprlevel<1) and (p^.left^.resulttype<>pdef(voiddef)) then
error(error_in_expression);
end;
procedure firstblock(var p : ptree);far;
var
hp : ptree;
count : longint;
begin
p^.registers32:=0;
count:=0;
hp:=p^.left;
while assigned(hp) do
begin
if cs_maxoptimieren in aktswitches then
begin
{ Codeumstellungen }
{ Funktionsresultate an exit anhängen }
if 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
warning(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=exitn) or
(hp^.right^.treetype=breakn) or
(hp^.right^.treetype=continuen) or
(hp^.right^.treetype=goton)) and
assigned(hp^.left) and
(hp^.left^.treetype<>labeln) then
begin
{ use correct line number }
inputstack:=hp^.left^.inputfile;
inputstack^.line_no:=hp^.left^.line;
disposetree(hp^.left);
hp^.left:=nil;
warning(unreachable_code);
{ old lines }
inputstack:=hp^.right^.inputfile;
inputstack^.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;
end
else
hp^.registers32:=0;
if hp^.registers32>p^.registers32 then
p^.registers32:=hp^.registers32;
inc(count);
hp:=hp^.left;
end;
{ p^.registers32:=round(p^.registers32/count); }
end;
procedure first_while_repeat(var p : ptree);far;
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;
firstpass(p^.left);
if codegenerror then
exit;
if not((p^.left^.resulttype^.deftype=grunddef) and
(pgrunddef(p^.left^.resulttype)^.typ=bool8bit)) then
begin
error(type_mismatch);
exit;
end;
p^.registers32:=p^.left^.registers32;
{ Schleifenanweisung }
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;
end;
t_times:=old_t_times;
end;
procedure firstif(var p : ptree);far;
var
old_t_times : longint;
begin
old_t_times:=t_times;
cleartempgen;
firstpass(p^.left);
if codegenerror then
exit;
if not((p^.left^.resulttype^.deftype=grunddef) and
(pgrunddef(p^.left^.resulttype)^.typ=bool8bit)) then
begin
error(type_mismatch);
exit;
end;
p^.registers32:=p^.left^.registers32;
{ Registergewichtung bestimmen }
if not(cs_littlesize in aktswitches ) then
t_times:=t_times div 2;
if t_times=0 then
t_times:=1;
{ if-Bedingung erfüllt }
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;
end;
{ else-Zweig }
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;
end;
t_times:=old_t_times;
end;
procedure firstexitn(var p : ptree);far;
begin
if assigned(p^.left) then
begin
firstpass(p^.left);
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
end
else
begin
p^.registers32:=0;
p^.registersfpu:=0;
end;
end;
procedure firstfor(var p : ptree);far;
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;
{ Fehler im Anweisungsblock sind egal }
cleartempgen;
firstpass(p^.t1);
p^.registers32:=p^.t1^.registers32;
p^.registersfpu:=p^.t1^.registersfpu;
if p^.left^.treetype<>assignn then
error(error_in_expression);
{ Laufvariable retten }
p^.t2:=getcopy(p^.left^.left);
{ Laufvar. auf Gültigkeit prüfen: }
if (p^.t2^.treetype<>loadn) then
error(invalid_for_var);
if (not(is_ordinal(p^.t2^.resulttype))) then
error(ordinal_expect);
cleartempgen;
firstpass(p^.left);
if p^.left^.registers32>p^.registers32 then
p^.registers32:=p^.left^.registers32;
if p^.left^.registersfpu>p^.registersfpu then
p^.registersfpu:=p^.left^.registersfpu;
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;
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;
t_times:=old_t_times;
end;
procedure firstasm(var p : ptree);far;
begin
{ it's a f... to determine the used registers }
p^.registers32:=0;
p^.registersfpu:=0;
procinfo.uses_asm:=true;
end;
procedure firstgoto(var p : ptree);far;
begin
p^.registers32:=0;
p^.registersfpu:=0;
p^.resulttype:=voiddef;
end;
procedure firstlabel(var p : ptree);far;
begin
cleartempgen;
firstpass(p^.left);
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
p^.resulttype:=voiddef;
end;
procedure firstcase(var p : ptree);far;
var
old_t_times : longint;
hp : ptree;
begin
{ evalutes the case expression }
cleartempgen;
firstpass(p^.left);
if codegenerror then
exit;
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{ 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;
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;
end;
t_times:=old_t_times;
{ there is one register required for the case expression }
if p^.registers32<1 then p^.registers32:=1;
end;
type
firstpassproc = procedure(var p : ptree);
procedure firstpass(var p : ptree);
const
procedures : array[addn..simplenewn] of firstpassproc =
(firstadd,firstadd,firstadd,firstmoddiv,
firstmoddiv,firstassignment,firstload,firstrange,
firstadd,firstadd,firstadd,firstadd,
firstadd,firstadd,firstin,firstadd,
firstadd,firstshlshr,firstshlshr,firstadd,
firstadd,firstsubscriptn,firstderef,firstaddr,
firstordconst,firsttypeconv,firstcalln,firstnothing,
firstrealconst,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,firstnothing,firstcase,firstlabel,
firstgoto,firstsimplenewdispose);
var
oldcodegenerror : boolean;
begin
oldcodegenerror:=codegenerror;
codegenerror:=false;
inputstack:=p^.inputfile;
inputstack^.line_no:=p^.line;
if not(p^.error) then
begin
procedures[p^.treetype](p);
p^.error:=codegenerror;
codegenerror:=codegenerror or oldcodegenerror;
end
else codegenerror:=true;
end;
function do_firstpass(var p : ptree) : boolean;
var
{ there some calls of do_firstpass in the parser }
oldis : pinputstack;
oldnr : longint;
begin
oldis:=inputstack;
oldnr:=inputstack^.line_no;
codegenerror:=false;
firstpass(p);
do_firstpass:=codegenerror;
inputstack:=oldis;
inputstack^.line_no:=oldnr;
end;
end.
