paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 18:29:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* move constant folding into det_resulttype

Browse Source
This commit is contained in:
peter 2001-04-04 22:42:39 +00:00
parent 226ea788db
commit 759f678192
6 changed files with 2108 additions and 2048 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

748
compiler/nadd.pas
View File

@ -76,10 +76,20 @@ implementation
function taddnode.det_resulttype:tnode;
var
hp : tnode;
hp,t : tnode;
lt,rt : tnodetype;
rd,ld : pdef;
htype : ttype;
ot : tnodetype;
concatstrings : boolean;
resultset : pconstset;
i : longint;
b : boolean;
s1,s2 : pchar;
l1,l2 : longint;
rv,lv : tconstexprint;
rvd,lvd : bestreal;
begin
result:=nil;
@ -113,6 +123,310 @@ implementation
rd:=right.resulttype.def;
end;
{ both are int constants }
if (((is_constintnode(left) and is_constintnode(right)) or
(is_constboolnode(left) and is_constboolnode(right) and
(nodetype in [ltn,lten,gtn,gten,equaln,unequaln,andn,xorn,orn])))) or
{ support pointer arithmetics on constants (JM) }
((lt = pointerconstn) and is_constintnode(right) and
(nodetype in [addn,subn])) or
((lt = pointerconstn) and (rt = pointerconstn) and
(nodetype in [ltn,lten,gtn,gten,equaln,unequaln,subn])) then
begin
{ when comparing/substracting pointers, make sure they are }
{ of the same type (JM) }
if (lt = pointerconstn) and (rt = pointerconstn) then
begin
if not(cs_extsyntax in aktmoduleswitches) and
not(nodetype in [equaln,unequaln]) then
CGMessage(type_e_mismatch)
else
if (nodetype <> subn) and
is_voidpointer(rd) then
inserttypeconv(right,left.resulttype)
else if (nodetype <> subn) and
is_voidpointer(ld) then
inserttypeconv(left,right.resulttype)
else if not(is_equal(ld,rd)) then
CGMessage(type_e_mismatch);
end
else if (lt=ordconstn) and (rt=ordconstn) then
begin
{ make left const type the biggest, this type will be used
for orn,andn,xorn }
if rd^.size>ld^.size then
inserttypeconv(left,right.resulttype);
end;
{ load values }
if (lt = ordconstn) then
lv:=tordconstnode(left).value
else
lv:=tpointerconstnode(left).value;
if (rt = ordconstn) then
rv:=tordconstnode(right).value
else
rv:=tpointerconstnode(right).value;
if (lt = pointerconstn) and
(rt <> pointerconstn) then
rv := rv * ppointerdef(left.resulttype.def)^.pointertype.def^.size;
if (rt = pointerconstn) and
(lt <> pointerconstn) then
lv := lv * ppointerdef(right.resulttype.def)^.pointertype.def^.size;
case nodetype of
addn :
if (lt <> pointerconstn) then
t := genintconstnode(lv+rv)
else
t := cpointerconstnode.create(lv+rv,left.resulttype);
subn :
if (lt <> pointerconstn) or (rt = pointerconstn) then
t := genintconstnode(lv-rv)
else
t := cpointerconstnode.create(lv-rv,left.resulttype);
muln :
t:=genintconstnode(lv*rv);
xorn :
t:=cordconstnode.create(lv xor rv,left.resulttype);
orn :
t:=cordconstnode.create(lv or rv,left.resulttype);
andn :
t:=cordconstnode.create(lv and rv,left.resulttype);
ltn :
t:=cordconstnode.create(ord(lv<rv),booltype);
lten :
t:=cordconstnode.create(ord(lv<=rv),booltype);
gtn :
t:=cordconstnode.create(ord(lv>rv),booltype);
gten :
t:=cordconstnode.create(ord(lv>=rv),booltype);
equaln :
t:=cordconstnode.create(ord(lv=rv),booltype);
unequaln :
t:=cordconstnode.create(ord(lv<>rv),booltype);
slashn :
begin
{ int/int becomes a real }
if int(rv)=0 then
begin
Message(parser_e_invalid_float_operation);
t:=crealconstnode.create(0,pbestrealtype^);
end
else
t:=crealconstnode.create(int(lv)/int(rv),pbestrealtype^);
end;
else
CGMessage(type_e_mismatch);
end;
resulttypepass(t);
result:=t;
exit;
end;
{ both real constants ? }
if (lt=realconstn) and (rt=realconstn) then
begin
lvd:=trealconstnode(left).value_real;
rvd:=trealconstnode(right).value_real;
case nodetype of
addn :
t:=crealconstnode.create(lvd+rvd,pbestrealtype^);
subn :
t:=crealconstnode.create(lvd-rvd,pbestrealtype^);
muln :
t:=crealconstnode.create(lvd*rvd,pbestrealtype^);
starstarn,
caretn :
begin
if lvd<0 then
begin
Message(parser_e_invalid_float_operation);
t:=crealconstnode.create(0,pbestrealtype^);
end
else if lvd=0 then
t:=crealconstnode.create(1.0,pbestrealtype^)
else
t:=crealconstnode.create(exp(ln(lvd)*rvd),pbestrealtype^);
end;
slashn :
begin
if rvd=0 then
begin
Message(parser_e_invalid_float_operation);
t:=crealconstnode.create(0,pbestrealtype^);
end
else
t:=crealconstnode.create(lvd/rvd,pbestrealtype^);
end;
ltn :
t:=cordconstnode.create(ord(lvd<rvd),booltype);
lten :
t:=cordconstnode.create(ord(lvd<=rvd),booltype);
gtn :
t:=cordconstnode.create(ord(lvd>rvd),booltype);
gten :
t:=cordconstnode.create(ord(lvd>=rvd),booltype);
equaln :
t:=cordconstnode.create(ord(lvd=rvd),booltype);
unequaln :
t:=cordconstnode.create(ord(lvd<>rvd),booltype);
else
CGMessage(type_e_mismatch);
end;
resulttypepass(t);
result:=t;
exit;
end;
{ concating strings ? }
concatstrings:=false;
s1:=nil;
s2:=nil;
if (lt=ordconstn) and (rt=ordconstn) and
is_char(ld) and is_char(rd) then
begin
s1:=strpnew(char(byte(tordconstnode(left).value)));
s2:=strpnew(char(byte(tordconstnode(right).value)));
l1:=1;
l2:=1;
concatstrings:=true;
end
else
if (lt=stringconstn) and (rt=ordconstn) and is_char(rd) then
begin
s1:=tstringconstnode(left).getpcharcopy;
l1:=tstringconstnode(left).len;
s2:=strpnew(char(byte(tordconstnode(right).value)));
l2:=1;
concatstrings:=true;
end
else
if (lt=ordconstn) and (rt=stringconstn) and is_char(ld) then
begin
s1:=strpnew(char(byte(tordconstnode(left).value)));
l1:=1;
s2:=tstringconstnode(right).getpcharcopy;
l2:=tstringconstnode(right).len;
concatstrings:=true;
end
else if (lt=stringconstn) and (rt=stringconstn) then
begin
s1:=tstringconstnode(left).getpcharcopy;
l1:=tstringconstnode(left).len;
s2:=tstringconstnode(right).getpcharcopy;
l2:=tstringconstnode(right).len;
concatstrings:=true;
end;
if concatstrings then
begin
case nodetype of
addn :
t:=cstringconstnode.createpchar(concatansistrings(s1,s2,l1,l2),l1+l2);
ltn :
t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<0),booltype);
lten :
t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<=0),booltype);
gtn :
t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)>0),booltype);
gten :
t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)>=0),booltype);
equaln :
t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)=0),booltype);
unequaln :
t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<>0),booltype);
end;
ansistringdispose(s1,l1);
ansistringdispose(s2,l2);
resulttypepass(t);
result:=t;
exit;
end;
{ set constant evaluation }
if (right.nodetype=setconstn) and
not assigned(tsetconstnode(right).left) and
(left.nodetype=setconstn) and
not assigned(tsetconstnode(left).left) then
begin
new(resultset);
case nodetype of
addn :
begin
for i:=0 to 31 do
resultset^[i]:=tsetconstnode(right).value_set^[i] or tsetconstnode(left).value_set^[i];
t:=csetconstnode.create(resultset,left.resulttype);
end;
muln :
begin
for i:=0 to 31 do
resultset^[i]:=tsetconstnode(right).value_set^[i] and tsetconstnode(left).value_set^[i];
t:=csetconstnode.create(resultset,left.resulttype);
end;
subn :
begin
for i:=0 to 31 do
resultset^[i]:=tsetconstnode(left).value_set^[i] and not(tsetconstnode(right).value_set^[i]);
t:=csetconstnode.create(resultset,left.resulttype);
end;
symdifn :
begin
for i:=0 to 31 do
resultset^[i]:=tsetconstnode(left).value_set^[i] xor tsetconstnode(right).value_set^[i];
t:=csetconstnode.create(resultset,left.resulttype);
end;
unequaln :
begin
b:=true;
for i:=0 to 31 do
if tsetconstnode(right).value_set^[i]=tsetconstnode(left).value_set^[i] then
begin
b:=false;
break;
end;
t:=cordconstnode.create(ord(b),booltype);
end;
equaln :
begin
b:=true;
for i:=0 to 31 do
if tsetconstnode(right).value_set^[i]<>tsetconstnode(left).value_set^[i] then
begin
b:=false;
break;
end;
t:=cordconstnode.create(ord(b),booltype);
end;
lten :
begin
b := true;
For i := 0 to 31 Do
If (tsetconstnode(right).value_set^[i] And tsetconstnode(left).value_set^[i]) <>
tsetconstnode(left).value_set^[i] Then
Begin
b := false;
Break
End;
t := cordconstnode.create(ord(b),booltype);
End;
gten :
Begin
b := true;
For i := 0 to 31 Do
If (tsetconstnode(left).value_set^[i] And tsetconstnode(right).value_set^[i]) <>
tsetconstnode(right).value_set^[i] Then
Begin
b := false;
Break
End;
t := cordconstnode.create(ord(b),booltype);
End;
end;
dispose(resultset);
resulttypepass(t);
result:=t;
exit;
end;
{ allow operator overloading }
hp:=self;
if isbinaryoverloaded(hp) then
@ -147,7 +461,62 @@ implementation
inserttypeconv(left,right.resulttype);
ttypeconvnode(left).convtype:=tc_bool_2_int;
include(left.flags,nf_explizit);
end
end;
case nodetype of
xorn,
ltn,
lten,
gtn,
gten,
andn,
orn:
begin
end;
unequaln,
equaln:
begin
if not(cs_full_boolean_eval in aktlocalswitches) then
begin
{ Remove any compares with constants }
if (left.nodetype=ordconstn) then
begin
hp:=right;
b:=(tordconstnode(left).value<>0);
ot:=nodetype;
left.free;
left:=nil;
right:=nil;
if (not(b) and (ot=equaln)) or
(b and (ot=unequaln)) then
begin
hp:=cnotnode.create(hp);
resulttypepass(hp);
end;
result:=hp;
exit;
end;
if (right.nodetype=ordconstn) then
begin
hp:=left;
b:=(tordconstnode(right).value<>0);
ot:=nodetype;
right.free;
right:=nil;
left:=nil;
if (not(b) and (ot=equaln)) or
(b and (ot=unequaln)) then
begin
hp:=cnotnode.create(hp);
resulttypepass(hp);
end;
result:=hp;
exit;
end;
end;
end;
else
CGMessage(type_e_mismatch);
end;
end
{ Both are chars? }
else if is_char(rd) and is_char(ld) then
@ -565,23 +934,10 @@ implementation
function taddnode.pass_1 : tnode;
var
t,hp : tnode;
ot,
hp : tnode;
lt,rt : tnodetype;
rv,lv : tconstexprint;
rvd,lvd : bestreal;
rd,ld : pdef;
concatstrings : boolean;
{ to evalute const sets }
resultset : pconstset;
i : longint;
b : boolean;
s1,s2 : pchar;
l1,l2 : longint;
begin
result:=nil;
{ first do the two subtrees }
@ -596,284 +952,6 @@ implementation
rt:=right.nodetype;
lt:=left.nodetype;
{ both are int constants }
if (((is_constintnode(left) and is_constintnode(right)) or
(is_constboolnode(left) and is_constboolnode(right) and
(nodetype in [ltn,lten,gtn,gten,equaln,unequaln,andn,xorn,orn])))) or
{ support pointer arithmetics on constants (JM) }
((lt = pointerconstn) and is_constintnode(right) and
(nodetype in [addn,subn])) or
((lt = pointerconstn) and (rt = pointerconstn) and
(nodetype in [ltn,lten,gtn,gten,equaln,unequaln,subn])) then
begin
if (lt = ordconstn) then
lv:=tordconstnode(left).value
else
lv:=tpointerconstnode(left).value;
if (rt = ordconstn) then
rv:=tordconstnode(right).value
else
rv:=tpointerconstnode(right).value;
if (lt = pointerconstn) and
(rt <> pointerconstn) then
rv := rv * ppointerdef(left.resulttype.def)^.pointertype.def^.size;
if (rt = pointerconstn) and
(lt <> pointerconstn) then
lv := lv * ppointerdef(right.resulttype.def)^.pointertype.def^.size;
case nodetype of
addn :
if (lt <> pointerconstn) then
t := cordconstnode.create(lv+rv,resulttype)
else
t := cpointerconstnode.create(lv+rv,resulttype);
subn :
if (lt <> pointerconstn) or (rt = pointerconstn) then
t := cordconstnode.create(lv-rv,resulttype)
else
t := cpointerconstnode.create(lv-rv,resulttype);
muln :
t:=cordconstnode.create(lv*rv,resulttype);
xorn :
t:=cordconstnode.create(lv xor rv,resulttype);
orn :
t:=cordconstnode.create(lv or rv,resulttype);
andn :
t:=cordconstnode.create(lv and rv,resulttype);
ltn :
t:=cordconstnode.create(ord(lv<rv),resulttype);
lten :
t:=cordconstnode.create(ord(lv<=rv),resulttype);
gtn :
t:=cordconstnode.create(ord(lv>rv),resulttype);
gten :
t:=cordconstnode.create(ord(lv>=rv),resulttype);
equaln :
t:=cordconstnode.create(ord(lv=rv),resulttype);
unequaln :
t:=cordconstnode.create(ord(lv<>rv),resulttype);
slashn :
begin
{ int/int becomes a real }
if int(rv)=0 then
begin
Message(parser_e_invalid_float_operation);
t:=crealconstnode.create(0,resulttype);
end
else
t:=crealconstnode.create(int(lv)/int(rv),resulttype);
end;
else
CGMessage(type_e_mismatch);
end;
firstpass(t);
result:=t;
exit;
end;
{ both real constants ? }
if (lt=realconstn) and (rt=realconstn) then
begin
lvd:=trealconstnode(left).value_real;
rvd:=trealconstnode(right).value_real;
case nodetype of
addn :
t:=crealconstnode.create(lvd+rvd,pbestrealtype^);
subn :
t:=crealconstnode.create(lvd-rvd,pbestrealtype^);
muln :
t:=crealconstnode.create(lvd*rvd,pbestrealtype^);
starstarn,
caretn :
begin
if lvd<0 then
begin
Message(parser_e_invalid_float_operation);
t:=crealconstnode.create(0,pbestrealtype^);
end
else if lvd=0 then
t:=crealconstnode.create(1.0,pbestrealtype^)
else
t:=crealconstnode.create(exp(ln(lvd)*rvd),pbestrealtype^);
end;
slashn :
begin
if rvd=0 then
begin
Message(parser_e_invalid_float_operation);
t:=crealconstnode.create(0,pbestrealtype^);
end
else
t:=crealconstnode.create(lvd/rvd,pbestrealtype^);
end;
ltn :
t:=cordconstnode.create(ord(lvd<rvd),booltype);
lten :
t:=cordconstnode.create(ord(lvd<=rvd),booltype);
gtn :
t:=cordconstnode.create(ord(lvd>rvd),booltype);
gten :
t:=cordconstnode.create(ord(lvd>=rvd),booltype);
equaln :
t:=cordconstnode.create(ord(lvd=rvd),booltype);
unequaln :
t:=cordconstnode.create(ord(lvd<>rvd),booltype);
else
CGMessage(type_e_mismatch);
end;
firstpass(t);
result:=t;
exit;
end;
{ concating strings ? }
concatstrings:=false;
s1:=nil;
s2:=nil;
if (lt=ordconstn) and (rt=ordconstn) and
is_char(ld) and is_char(rd) then
begin
s1:=strpnew(char(byte(tordconstnode(left).value)));
s2:=strpnew(char(byte(tordconstnode(right).value)));
l1:=1;
l2:=1;
concatstrings:=true;
end
else
if (lt=stringconstn) and (rt=ordconstn) and is_char(rd) then
begin
s1:=tstringconstnode(left).getpcharcopy;
l1:=tstringconstnode(left).len;
s2:=strpnew(char(byte(tordconstnode(right).value)));
l2:=1;
concatstrings:=true;
end
else
if (lt=ordconstn) and (rt=stringconstn) and is_char(ld) then
begin
s1:=strpnew(char(byte(tordconstnode(left).value)));
l1:=1;
s2:=tstringconstnode(right).getpcharcopy;
l2:=tstringconstnode(right).len;
concatstrings:=true;
end
else if (lt=stringconstn) and (rt=stringconstn) then
begin
s1:=tstringconstnode(left).getpcharcopy;
l1:=tstringconstnode(left).len;
s2:=tstringconstnode(right).getpcharcopy;
l2:=tstringconstnode(right).len;
concatstrings:=true;
end;
if concatstrings then
begin
case nodetype of
addn :
t:=cstringconstnode.createpchar(concatansistrings(s1,s2,l1,l2),l1+l2);
ltn :
t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<0),booltype);
lten :
t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<=0),booltype);
gtn :
t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)>0),booltype);
gten :
t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)>=0),booltype);
equaln :
t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)=0),booltype);
unequaln :
t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<>0),booltype);
end;
ansistringdispose(s1,l1);
ansistringdispose(s2,l2);
firstpass(t);
result:=t;
exit;
end;
{ set constant evaluation }
if (right.nodetype=setconstn) and
not assigned(tsetconstnode(right).left) and
(left.nodetype=setconstn) and
not assigned(tsetconstnode(left).left) then
begin
new(resultset);
case nodetype of
addn :
begin
for i:=0 to 31 do
resultset^[i]:=tsetconstnode(right).value_set^[i] or tsetconstnode(left).value_set^[i];
t:=csetconstnode.create(resultset,left.resulttype);
end;
muln :
begin
for i:=0 to 31 do
resultset^[i]:=tsetconstnode(right).value_set^[i] and tsetconstnode(left).value_set^[i];
t:=csetconstnode.create(resultset,left.resulttype);
end;
subn :
begin
for i:=0 to 31 do
resultset^[i]:=tsetconstnode(left).value_set^[i] and not(tsetconstnode(right).value_set^[i]);
t:=csetconstnode.create(resultset,left.resulttype);
end;
symdifn :
begin
for i:=0 to 31 do
resultset^[i]:=tsetconstnode(left).value_set^[i] xor tsetconstnode(right).value_set^[i];
t:=csetconstnode.create(resultset,left.resulttype);
end;
unequaln :
begin
b:=true;
for i:=0 to 31 do
if tsetconstnode(right).value_set^[i]=tsetconstnode(left).value_set^[i] then
begin
b:=false;
break;
end;
t:=cordconstnode.create(ord(b),booltype);
end;
equaln :
begin
b:=true;
for i:=0 to 31 do
if tsetconstnode(right).value_set^[i]<>tsetconstnode(left).value_set^[i] then
begin
b:=false;
break;
end;
t:=cordconstnode.create(ord(b),booltype);
end;
lten :
begin
b := true;
For i := 0 to 31 Do
If (tsetconstnode(right).value_set^[i] And tsetconstnode(left).value_set^[i]) <>
tsetconstnode(left).value_set^[i] Then
Begin
b := false;
Break
End;
t := cordconstnode.create(ord(b),booltype);
End;
gten :
Begin
b := true;
For i := 0 to 31 Do
If (tsetconstnode(left).value_set^[i] And tsetconstnode(right).value_set^[i]) <>
tsetconstnode(right).value_set^[i] Then
Begin
b := false;
Break
End;
t := cordconstnode.create(ord(b),booltype);
End;
end;
dispose(resultset);
firstpass(t);
result:=t;
exit;
end;
{ int/int gives real/real! }
if nodetype=slashn then
begin
@ -894,71 +972,20 @@ implementation
{ 2 booleans ? }
if is_boolean(ld) and is_boolean(rd) then
begin
if (cs_full_boolean_eval in aktlocalswitches) or
(nodetype in [xorn,ltn,lten,gtn,gten]) then
begin
if (left.location.loc in [LOC_JUMP,LOC_FLAGS]) and
(left.location.loc in [LOC_JUMP,LOC_FLAGS]) then
calcregisters(self,2,0,0)
else
calcregisters(self,1,0,0);
end
if not(cs_full_boolean_eval in aktlocalswitches) and
(nodetype in [andn,orn]) then
begin
calcregisters(self,0,0,0);
location.loc:=LOC_JUMP;
end
else
case nodetype of
andn,
orn:
begin
calcregisters(self,0,0,0);
location.loc:=LOC_JUMP;
end;
unequaln,
equaln:
begin
{ Remove any compares with constants }
if (left.nodetype=ordconstn) then
begin
hp:=right;
b:=(tordconstnode(left).value<>0);
ot:=nodetype;
left.free;
left:=nil;
right:=nil;
if (not(b) and (ot=equaln)) or
(b and (ot=unequaln)) then
begin
hp:=cnotnode.create(hp);
firstpass(hp);
end;
result:=hp;
exit;
end;
if (right.nodetype=ordconstn) then
begin
hp:=left;
b:=(tordconstnode(right).value<>0);
ot:=nodetype;
right.free;
right:=nil;
left:=nil;
if (not(b) and (ot=equaln)) or
(b and (ot=unequaln)) then
begin
hp:=cnotnode.create(hp);
firstpass(hp);
end;
result:=hp;
exit;
end;
if (left.location.loc in [LOC_JUMP,LOC_FLAGS]) and
(left.location.loc in [LOC_JUMP,LOC_FLAGS]) then
calcregisters(self,2,0,0)
else
calcregisters(self,1,0,0);
end;
else
CGMessage(type_e_mismatch);
end;
begin
if (left.location.loc in [LOC_JUMP,LOC_FLAGS]) and
(left.location.loc in [LOC_JUMP,LOC_FLAGS]) then
calcregisters(self,2,0,0)
else
calcregisters(self,1,0,0);
end;
end
else
{ Both are chars? only convert to shortstrings for addn }
@ -1170,7 +1197,10 @@ begin
end.
{
$Log$
Revision 1.23 2001-04-02 21:20:30 peter
Revision 1.24 2001-04-04 22:42:39 peter
* move constant folding into det_resulttype
Revision 1.23 2001/04/02 21:20:30 peter
* resulttype rewrite
Revision 1.22 2001/02/04 11:12:17 jonas

22
compiler/ncal.pas
View File

@ -1268,6 +1268,16 @@ implementation
{ ensure that the result type is set }
resulttype:=procdefinition^.rettype;
{ constructors return their current class type, not the type where the
constructor is declared, this can be different because of inheritance }
if (procdefinition^.proctypeoption=potype_constructor) then
begin
if assigned(methodpointer) and
assigned(methodpointer.resulttype.def) and
(methodpointer.resulttype.def^.deftype=classrefdef) then
resulttype:=pclassrefdef(methodpointer.resulttype.def)^.pointertype;
end;
{ insert type conversions }
if assigned(left) then
tcallparanode(left).insert_typeconv(tparaitem(procdefinition^.Para.first),true);
@ -1388,13 +1398,12 @@ implementation
begin
{ extra handling of classes }
{ methodpointer should be assigned! }
if assigned(methodpointer) and assigned(methodpointer.resulttype.def) and
(methodpointer.resulttype.def^.deftype=classrefdef) then
if assigned(methodpointer) and
assigned(methodpointer.resulttype.def) and
(methodpointer.resulttype.def^.deftype=classrefdef) then
begin
location.loc:=LOC_REGISTER;
registers32:=1;
{ the result type depends on the classref }
resulttype:=pclassrefdef(methodpointer.resulttype.def)^.pointertype;
end
{ a object constructor returns the result with the flags }
else
@ -1604,7 +1613,10 @@ begin
end.
{
$Log$
Revision 1.25 2001-04-02 21:20:30 peter
Revision 1.26 2001-04-04 22:42:39 peter
* move constant folding into det_resulttype
Revision 1.25 2001/04/02 21:20:30 peter
* resulttype rewrite
Revision 1.24 2001/03/12 12:47:46 michael

606
compiler/ncnv.pas
View File

@ -40,6 +40,15 @@ interface
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
function docompare(p: tnode) : boolean; override;
private
function resulttype_cord_to_pointer : tnode;
function resulttype_string_to_string : tnode;
function resulttype_char_to_string : tnode;
function resulttype_int_to_real : tnode;
function resulttype_real_to_real : tnode;
function resulttype_cchar_to_pchar : tnode;
function resulttype_arrayconstructor_to_set : tnode;
function resulttype_call_helper(c : tconverttype) : tnode;
protected
function first_int_to_int : tnode;virtual;
function first_cstring_to_pchar : tnode;virtual;
@ -218,10 +227,9 @@ implementation
p.left:=nil;
p3:=nil;
end;
{$warning todo: firstpass}
firstpass(p2);
resulttypepass(p2);
if assigned(p3) then
firstpass(p3);
resulttypepass(p3);
if codegenerror then
break;
case p2.resulttype.def^.deftype of
@ -382,11 +390,11 @@ implementation
end;
function ttypeconvnode.first_cord_to_pointer : tnode;
function ttypeconvnode.resulttype_cord_to_pointer : tnode;
var
t : tnode;
begin
first_cord_to_pointer:=nil;
result:=nil;
if left.nodetype=ordconstn then
begin
{ check if we have a valid pointer constant (JM) }
@ -406,260 +414,86 @@ implementation
else
internalerror(2001020801);
t:=cpointerconstnode.create(tpointerord(tordconstnode(left).value),resulttype);
firstpass(t);
first_cord_to_pointer:=t;
exit;
resulttypepass(t);
result:=t;
end
else
internalerror(432472389);
else
internalerror(200104023);
end;
function ttypeconvnode.first_int_to_int : tnode;
function ttypeconvnode.resulttype_string_to_string : tnode;
begin
first_int_to_int:=nil;
if (left.location.loc<>LOC_REGISTER) and
(resulttype.def^.size>left.resulttype.def^.size) then
location.loc:=LOC_REGISTER;
if is_64bitint(resulttype.def) then
registers32:=max(registers32,2)
else
registers32:=max(registers32,1);
result:=nil;
if left.nodetype=stringconstn then
begin
tstringconstnode(left).st_type:=pstringdef(resulttype.def)^.string_typ;
tstringconstnode(left).resulttype:=resulttype;
result:=left;
left:=nil;
end;
end;
function ttypeconvnode.first_cstring_to_pchar : tnode;
begin
first_cstring_to_pchar:=nil;
registers32:=1;
location.loc:=LOC_REGISTER;
end;
function ttypeconvnode.first_string_to_chararray : tnode;
begin
first_string_to_chararray:=nil;
registers32:=1;
location.loc:=LOC_REGISTER;
end;
function ttypeconvnode.first_string_to_string : tnode;
begin
first_string_to_string:=nil;
if pstringdef(resulttype.def)^.string_typ<>
pstringdef(left.resulttype.def)^.string_typ then
begin
if left.nodetype=stringconstn then
begin
tstringconstnode(left).st_type:=pstringdef(resulttype.def)^.string_typ;
tstringconstnode(left).resulttype:=resulttype;
{ remove typeconv node }
first_string_to_string:=left;
left:=nil;
exit;
end
else
procinfo^.flags:=procinfo^.flags or pi_do_call;
end;
{ for simplicity lets first keep all ansistrings
as LOC_MEM, could also become LOC_REGISTER }
if pstringdef(resulttype.def)^.string_typ in [st_ansistring,st_widestring] then
{ we may use ansistrings so no fast exit here }
procinfo^.no_fast_exit:=true;
location.loc:=LOC_MEM;
end;
function ttypeconvnode.first_char_to_string : tnode;
function ttypeconvnode.resulttype_char_to_string : tnode;
var
hp : tstringconstnode;
begin
first_char_to_string:=nil;
result:=nil;
if left.nodetype=ordconstn then
begin
hp:=cstringconstnode.createstr(chr(tordconstnode(left).value),st_default);
hp.st_type:=pstringdef(resulttype.def)^.string_typ;
firstpass(hp);
first_char_to_string:=hp;
end
else
location.loc:=LOC_MEM;
resulttypepass(hp);
result:=hp;
end;
end;
function ttypeconvnode.first_nothing : tnode;
begin
first_nothing:=nil;
location.loc:=LOC_MEM;
end;
function ttypeconvnode.first_array_to_pointer : tnode;
begin
first_array_to_pointer:=nil;
if registers32<1 then
registers32:=1;
location.loc:=LOC_REGISTER;
end;
function ttypeconvnode.first_int_to_real : tnode;
function ttypeconvnode.resulttype_int_to_real : tnode;
var
t : trealconstnode;
begin
first_int_to_real:=nil;
result:=nil;
if left.nodetype=ordconstn then
begin
t:=crealconstnode.create(tordconstnode(left).value,resulttype);
firstpass(t);
first_int_to_real:=t;
resulttypepass(t);
result:=t;
exit;
end;
if registersfpu<1 then
registersfpu:=1;
location.loc:=LOC_FPU;
end;
function ttypeconvnode.first_real_to_real : tnode;
function ttypeconvnode.resulttype_real_to_real : tnode;
var
t : tnode;
begin
first_real_to_real:=nil;
result:=nil;
if left.nodetype=realconstn then
begin
t:=crealconstnode.create(trealconstnode(left).value_real,resulttype);
firstpass(t);
first_real_to_real:=t;
exit;
resulttypepass(t);
result:=t;
end;
{ comp isn't a floating type }
{$ifdef i386}
if (pfloatdef(resulttype.def)^.typ=s64comp) and
(pfloatdef(left.resulttype.def)^.typ<>s64comp) and
not (nf_explizit in flags) then
CGMessage(type_w_convert_real_2_comp);
{$endif}
if registersfpu<1 then
registersfpu:=1;
location.loc:=LOC_FPU;
end;
function ttypeconvnode.first_pointer_to_array : tnode;
function ttypeconvnode.resulttype_cchar_to_pchar : tnode;
begin
first_pointer_to_array:=nil;
if registers32<1 then
registers32:=1;
location.loc:=LOC_REFERENCE;
end;
function ttypeconvnode.first_chararray_to_string : tnode;
begin
first_chararray_to_string:=nil;
{ the only important information is the location of the }
{ result }
{ other stuff is done by firsttypeconv }
location.loc:=LOC_MEM;
end;
function ttypeconvnode.first_cchar_to_pchar : tnode;
begin
first_cchar_to_pchar:=nil;
result:=nil;
inserttypeconv(left,cshortstringtype);
{ evaluate again, reset resulttype so the convert_typ
will be calculated again }
det_resulttype;
first_cchar_to_pchar:=pass_1;
result:=det_resulttype;
end;
function ttypeconvnode.first_bool_to_int : tnode;
begin
first_bool_to_int:=nil;
{ byte(boolean) or word(wordbool) or longint(longbool) must
be accepted for var parameters }
if (nf_explizit in flags) and
(left.resulttype.def^.size=resulttype.def^.size) and
(left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
exit;
location.loc:=LOC_REGISTER;
if registers32<1 then
registers32:=1;
end;
function ttypeconvnode.first_int_to_bool : tnode;
begin
first_int_to_bool:=nil;
{ byte(boolean) or word(wordbool) or longint(longbool) must
be accepted for var parameters }
if (nf_explizit in flags) and
(left.resulttype.def^.size=resulttype.def^.size) and
(left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
exit;
location.loc:=LOC_REGISTER;
{ need if bool to bool !!
not very nice !!
insertypeconv(left,s32bittype);
left.explizit:=true;
firstpass(left); }
if registers32<1 then
registers32:=1;
end;
function ttypeconvnode.first_bool_to_bool : tnode;
begin
first_bool_to_bool:=nil;
location.loc:=LOC_REGISTER;
if registers32<1 then
registers32:=1;
end;
function ttypeconvnode.first_proc_to_procvar : tnode;
begin
first_proc_to_procvar:=nil;
if (left.location.loc<>LOC_REFERENCE) then
CGMessage(cg_e_illegal_expression);
registers32:=left.registers32;
if registers32<1 then
registers32:=1;
location.loc:=LOC_REGISTER;
end;
function ttypeconvnode.first_load_smallset : tnode;
begin
first_load_smallset:=nil;
end;
function ttypeconvnode.first_pchar_to_string : tnode;
begin
first_pchar_to_string:=nil;
location.loc:=LOC_REFERENCE;
end;
function ttypeconvnode.first_ansistring_to_pchar : tnode;
begin
first_ansistring_to_pchar:=nil;
location.loc:=LOC_REGISTER;
if registers32<1 then
registers32:=1;
end;
function ttypeconvnode.first_arrayconstructor_to_set : tnode;
function ttypeconvnode.resulttype_arrayconstructor_to_set : tnode;
var
hp : tnode;
begin
first_arrayconstructor_to_set:=nil;
result:=nil;
if left.nodetype<>arrayconstructorn then
internalerror(5546);
{ remove typeconv node }
@ -668,64 +502,56 @@ implementation
{ create a set constructor tree }
arrayconstructor_to_set(tarrayconstructornode(hp));
{ now resulttypepass the set }
firstpass(hp);
first_arrayconstructor_to_set:=hp;
resulttypepass(hp);
result:=hp;
end;
function ttypeconvnode.first_class_to_intf : tnode;
begin
first_class_to_intf:=nil;
location.loc:=LOC_REFERENCE;
if registers32<1 then
registers32:=1;
end;
function ttypeconvnode.first_call_helper(c : tconverttype) : tnode;
function ttypeconvnode.resulttype_call_helper(c : tconverttype) : tnode;
const
firstconvert : array[tconverttype] of pointer = (
@ttypeconvnode.first_nothing, {equal}
@ttypeconvnode.first_nothing, {not_possible}
@ttypeconvnode.first_string_to_string,
@ttypeconvnode.first_char_to_string,
@ttypeconvnode.first_pchar_to_string,
@ttypeconvnode.first_cchar_to_pchar,
@ttypeconvnode.first_cstring_to_pchar,
@ttypeconvnode.first_ansistring_to_pchar,
@ttypeconvnode.first_string_to_chararray,
@ttypeconvnode.first_chararray_to_string,
@ttypeconvnode.first_array_to_pointer,
@ttypeconvnode.first_pointer_to_array,
@ttypeconvnode.first_int_to_int,
@ttypeconvnode.first_int_to_bool,
@ttypeconvnode.first_bool_to_bool,
@ttypeconvnode.first_bool_to_int,
@ttypeconvnode.first_real_to_real,
@ttypeconvnode.first_int_to_real,
@ttypeconvnode.first_proc_to_procvar,
@ttypeconvnode.first_arrayconstructor_to_set,
@ttypeconvnode.first_load_smallset,
@ttypeconvnode.first_cord_to_pointer,
@ttypeconvnode.first_nothing,
@ttypeconvnode.first_nothing,
@ttypeconvnode.first_class_to_intf
resulttypeconvert : array[tconverttype] of pointer = (
{equal} nil,
{not_possible} nil,
{ string_2_string } @ttypeconvnode.resulttype_string_to_string,
{ char_2_string } @ttypeconvnode.resulttype_char_to_string,
{ pchar_2_string } nil,
{ cchar_2_pchar } @ttypeconvnode.resulttype_cchar_to_pchar,
{ cstring_2_pchar } nil,
{ ansistring_2_pchar } nil,
{ string_2_chararray } nil,
{ chararray_2_string } nil,
{ array_2_pointer } nil,
{ pointer_2_array } nil,
{ int_2_int } nil,
{ int_2_bool } nil,
{ bool_2_bool } nil,
{ bool_2_int } nil,
{ real_2_real } @ttypeconvnode.resulttype_real_to_real,
{ int_2_real } @ttypeconvnode.resulttype_int_to_real,
{ proc_2_procvar } nil,
{ arrayconstructor_2_set } @ttypeconvnode.resulttype_arrayconstructor_to_set,
{ load_smallset } nil,
{ cord_2_pointer } @ttypeconvnode.resulttype_cord_to_pointer,
{ intf_2_string } nil,
{ intf_2_guid } nil,
{ class_2_intf } nil
);
type
tprocedureofobject = function : tnode of object;
var
r : packed record
proc : pointer;
obj : pointer;
end;
begin
result:=nil;
{ this is a little bit dirty but it works }
{ and should be quite portable too }
r.proc:=firstconvert[c];
r.proc:=resulttypeconvert[c];
r.obj:=self;
first_call_helper:=tprocedureofobject(r){$ifdef FPC}();{$endif FPC}
if assigned(r.proc) then
result:=tprocedureofobject(r){$ifdef FPC}();{$endif FPC}
end;
@ -784,8 +610,6 @@ implementation
exit;
end;
{$WARNING Todo: remove firstpass}
firstpass(left);
if isconvertable(left.resulttype.def,resulttype.def,convtype,left.nodetype,nf_explizit in flags)=0 then
begin
{Procedures have a resulttype.def of voiddef and functions of their
@ -1025,6 +849,277 @@ implementation
result:=hp;
exit;
end;
{ now call the resulttype helper to do constant folding }
result:=resulttype_call_helper(convtype);
end;
function ttypeconvnode.first_cord_to_pointer : tnode;
begin
result:=nil;
internalerror(200104043);
end;
function ttypeconvnode.first_int_to_int : tnode;
begin
first_int_to_int:=nil;
if (left.location.loc<>LOC_REGISTER) and
(resulttype.def^.size>left.resulttype.def^.size) then
location.loc:=LOC_REGISTER;
if is_64bitint(resulttype.def) then
registers32:=max(registers32,2)
else
registers32:=max(registers32,1);
end;
function ttypeconvnode.first_cstring_to_pchar : tnode;
begin
first_cstring_to_pchar:=nil;
registers32:=1;
location.loc:=LOC_REGISTER;
end;
function ttypeconvnode.first_string_to_chararray : tnode;
begin
first_string_to_chararray:=nil;
registers32:=1;
location.loc:=LOC_REGISTER;
end;
function ttypeconvnode.first_string_to_string : tnode;
begin
first_string_to_string:=nil;
if pstringdef(resulttype.def)^.string_typ<>
pstringdef(left.resulttype.def)^.string_typ then
begin
procinfo^.flags:=procinfo^.flags or pi_do_call;
end;
{ for simplicity lets first keep all ansistrings
as LOC_MEM, could also become LOC_REGISTER }
if pstringdef(resulttype.def)^.string_typ in [st_ansistring,st_widestring] then
{ we may use ansistrings so no fast exit here }
procinfo^.no_fast_exit:=true;
location.loc:=LOC_MEM;
end;
function ttypeconvnode.first_char_to_string : tnode;
begin
first_char_to_string:=nil;
location.loc:=LOC_MEM;
end;
function ttypeconvnode.first_nothing : tnode;
begin
first_nothing:=nil;
location.loc:=LOC_MEM;
end;
function ttypeconvnode.first_array_to_pointer : tnode;
begin
first_array_to_pointer:=nil;
if registers32<1 then
registers32:=1;
location.loc:=LOC_REGISTER;
end;
function ttypeconvnode.first_int_to_real : tnode;
begin
first_int_to_real:=nil;
if registersfpu<1 then
registersfpu:=1;
location.loc:=LOC_FPU;
end;
function ttypeconvnode.first_real_to_real : tnode;
begin
first_real_to_real:=nil;
{ comp isn't a floating type }
{$ifdef i386}
if (pfloatdef(resulttype.def)^.typ=s64comp) and
(pfloatdef(left.resulttype.def)^.typ<>s64comp) and
not (nf_explizit in flags) then
CGMessage(type_w_convert_real_2_comp);
{$endif}
if registersfpu<1 then
registersfpu:=1;
location.loc:=LOC_FPU;
end;
function ttypeconvnode.first_pointer_to_array : tnode;
begin
first_pointer_to_array:=nil;
if registers32<1 then
registers32:=1;
location.loc:=LOC_REFERENCE;
end;
function ttypeconvnode.first_chararray_to_string : tnode;
begin
first_chararray_to_string:=nil;
{ the only important information is the location of the }
{ result }
{ other stuff is done by firsttypeconv }
location.loc:=LOC_MEM;
end;
function ttypeconvnode.first_cchar_to_pchar : tnode;
begin
first_cchar_to_pchar:=nil;
internalerror(200104021);
end;
function ttypeconvnode.first_bool_to_int : tnode;
begin
first_bool_to_int:=nil;
{ byte(boolean) or word(wordbool) or longint(longbool) must
be accepted for var parameters }
if (nf_explizit in flags) and
(left.resulttype.def^.size=resulttype.def^.size) and
(left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
exit;
location.loc:=LOC_REGISTER;
if registers32<1 then
registers32:=1;
end;
function ttypeconvnode.first_int_to_bool : tnode;
begin
first_int_to_bool:=nil;
{ byte(boolean) or word(wordbool) or longint(longbool) must
be accepted for var parameters }
if (nf_explizit in flags) and
(left.resulttype.def^.size=resulttype.def^.size) and
(left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
exit;
location.loc:=LOC_REGISTER;
{ need if bool to bool !!
not very nice !!
insertypeconv(left,s32bittype);
left.explizit:=true;
firstpass(left); }
if registers32<1 then
registers32:=1;
end;
function ttypeconvnode.first_bool_to_bool : tnode;
begin
first_bool_to_bool:=nil;
location.loc:=LOC_REGISTER;
if registers32<1 then
registers32:=1;
end;
function ttypeconvnode.first_proc_to_procvar : tnode;
begin
first_proc_to_procvar:=nil;
if (left.location.loc<>LOC_REFERENCE) then
CGMessage(cg_e_illegal_expression);
registers32:=left.registers32;
if registers32<1 then
registers32:=1;
location.loc:=LOC_REGISTER;
end;
function ttypeconvnode.first_load_smallset : tnode;
begin
first_load_smallset:=nil;
end;
function ttypeconvnode.first_pchar_to_string : tnode;
begin
first_pchar_to_string:=nil;
location.loc:=LOC_REFERENCE;
end;
function ttypeconvnode.first_ansistring_to_pchar : tnode;
begin
first_ansistring_to_pchar:=nil;
location.loc:=LOC_REGISTER;
if registers32<1 then
registers32:=1;
end;
function ttypeconvnode.first_arrayconstructor_to_set : tnode;
begin
first_arrayconstructor_to_set:=nil;
internalerror(200104022);
end;
function ttypeconvnode.first_class_to_intf : tnode;
begin
first_class_to_intf:=nil;
location.loc:=LOC_REFERENCE;
if registers32<1 then
registers32:=1;
end;
function ttypeconvnode.first_call_helper(c : tconverttype) : tnode;
const
firstconvert : array[tconverttype] of pointer = (
@ttypeconvnode.first_nothing, {equal}
@ttypeconvnode.first_nothing, {not_possible}
@ttypeconvnode.first_string_to_string,
@ttypeconvnode.first_char_to_string,
@ttypeconvnode.first_pchar_to_string,
@ttypeconvnode.first_cchar_to_pchar,
@ttypeconvnode.first_cstring_to_pchar,
@ttypeconvnode.first_ansistring_to_pchar,
@ttypeconvnode.first_string_to_chararray,
@ttypeconvnode.first_chararray_to_string,
@ttypeconvnode.first_array_to_pointer,
@ttypeconvnode.first_pointer_to_array,
@ttypeconvnode.first_int_to_int,
@ttypeconvnode.first_int_to_bool,
@ttypeconvnode.first_bool_to_bool,
@ttypeconvnode.first_bool_to_int,
@ttypeconvnode.first_real_to_real,
@ttypeconvnode.first_int_to_real,
@ttypeconvnode.first_proc_to_procvar,
@ttypeconvnode.first_arrayconstructor_to_set,
@ttypeconvnode.first_load_smallset,
@ttypeconvnode.first_cord_to_pointer,
@ttypeconvnode.first_nothing,
@ttypeconvnode.first_nothing,
@ttypeconvnode.first_class_to_intf
);
type
tprocedureofobject = function : tnode of object;
var
r : packed record
proc : pointer;
obj : pointer;
end;
begin
{ this is a little bit dirty but it works }
{ and should be quite portable too }
r.proc:=firstconvert[c];
r.obj:=self;
first_call_helper:=tprocedureofobject(r){$ifdef FPC}();{$endif FPC}
end;
@ -1200,7 +1295,10 @@ begin
end.
{
$Log$
Revision 1.22 2001-04-02 21:20:30 peter
Revision 1.23 2001-04-04 22:42:39 peter
* move constant folding into det_resulttype
Revision 1.22 2001/04/02 21:20:30 peter
* resulttype rewrite
Revision 1.21 2001/03/08 17:44:47 jonas

2538
compiler/ninl.pas
View File

File diff suppressed because it is too large Load Diff

84
compiler/nld.pas
View File

@ -164,6 +164,8 @@ implementation
p1 : tnode;
begin
result:=nil;
{ optimize simple with loadings }
if (symtable^.symtabletype=withsymtable) and
(pwithsymtable(symtable)^.direct_with) and
(symtableentry^.typ=varsym) then
@ -312,6 +314,7 @@ implementation
(symtable = tloadnode(p).symtable);
end;
{*****************************************************************************
TASSIGNMENTNODE
*****************************************************************************}
@ -440,6 +443,7 @@ implementation
(assigntype = tassignmentnode(p).assigntype);
end;
{*****************************************************************************
TFUNCRETNODE
*****************************************************************************}
@ -451,6 +455,7 @@ implementation
funcretprocinfo:=p;
end;
function tfuncretnode.getcopy : tnode;
var
n : tfuncretnode;
@ -460,12 +465,14 @@ implementation
getcopy:=n;
end;
function tfuncretnode.det_resulttype:tnode;
begin
result:=nil;
resulttype:=pprocinfo(funcretprocinfo)^.returntype;
end;
function tfuncretnode.pass_1 : tnode;
begin
result:=nil;
@ -475,6 +482,7 @@ implementation
registers32:=1;
end;
function tfuncretnode.docompare(p: tnode): boolean;
begin
docompare :=
@ -482,6 +490,7 @@ implementation
(funcretprocinfo = tfuncretnode(p).funcretprocinfo);
end;
{*****************************************************************************
TARRAYCONSTRUCTORRANGENODE
*****************************************************************************}
@ -519,23 +528,22 @@ implementation
*****************************************************************************}
constructor tarrayconstructornode.create(l,r : tnode);
begin
inherited create(arrayconstructorn,l,r);
constructortype.reset;
end;
function tarrayconstructornode.getcopy : tnode;
function tarrayconstructornode.getcopy : tnode;
var
n : tarrayconstructornode;
begin
n:=tarrayconstructornode(inherited getcopy);
n.constructortype:=constructortype;
result:=n;
end;
function tarrayconstructornode.det_resulttype:tnode;
var
htype : ttype;
@ -544,6 +552,7 @@ implementation
varia : boolean;
begin
result:=nil;
{ are we allowing array constructor? Then convert it to a set }
if not allow_array_constructor then
begin
@ -553,6 +562,7 @@ implementation
result:=hp;
exit;
end;
{ only pass left tree, right tree contains next construct if any }
htype:=constructortype;
len:=0;
@ -589,43 +599,12 @@ implementation
function tarrayconstructornode.pass_1 : tnode;
var
htype : ttype;
thp,
chp,
hp : tarrayconstructornode;
len : longint;
varia : boolean;
procedure postprocess(t : tnode);
begin
calcregisters(tbinarynode(t),0,0,0);
{ looks a little bit dangerous to me }
{ len-1 gives problems with is_open_array if len=0, }
{ is_open_array checks now for isconstructor (FK) }
{ if no type is set then we set the type to voiddef to overcome a
0 addressing }
if not assigned(htype.def) then
htype:=voidtype;
{ skip if already done ! (PM) }
if not assigned(t.resulttype.def) or
(t.resulttype.def^.deftype<>arraydef) or
not parraydef(t.resulttype.def)^.IsConstructor or
(parraydef(t.resulttype.def)^.lowrange<>0) or
(parraydef(t.resulttype.def)^.highrange<>len-1) then
t.resulttype.setdef(new(parraydef,init(0,len-1,s32bittype)));
parraydef(t.resulttype.def)^.elementtype:=htype;
parraydef(t.resulttype.def)^.IsConstructor:=true;
parraydef(t.resulttype.def)^.IsVariant:=varia;
t.location.loc:=LOC_MEM;
end;
begin
result:=nil;
{ only pass left tree, right tree contains next construct if any }
htype:=constructortype;
len:=0;
varia:=false;
if assigned(left) then
begin
hp:=self;
@ -633,8 +612,8 @@ implementation
begin
firstpass(hp.left);
set_varstate(hp.left,true);
if (not get_para_resulttype) and
(not(nf_novariaallowed in flags)) then
{ Insert typeconvs for array of const }
if parraydef(resulttype.def)^.IsVariant then
begin
case hp.left.resulttype.def^.deftype of
enumdef :
@ -676,23 +655,6 @@ implementation
CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def^.typename);
end;
end;
if (htype.def=nil) then
htype:=hp.left.resulttype
else
begin
if ((nf_novariaallowed in flags) or (not varia)) and
(not is_equal(htype.def,hp.left.resulttype.def)) then
begin
{ if both should be equal try inserting a conversion }
if nf_novariaallowed in flags then
begin
hp.left:=ctypeconvnode.create(hp.left,htype);
firstpass(hp.left);
end;
varia:=true;
end;
end;
inc(len);
hp:=tarrayconstructornode(hp.right);
end;
{ swap the tree for cargs }
@ -711,14 +673,17 @@ implementation
end;
include(chp.flags,nf_cargs);
include(chp.flags,nf_cargswap);
postprocess(chp);
calcregisters(chp,0,0,0);
chp.location.loc:=LOC_MEM;
result:=chp;
exit;
end;
end;
postprocess(self);
calcregisters(self,0,0,0);
location.loc:=LOC_MEM;
end;
function tarrayconstructornode.docompare(p: tnode): boolean;
begin
docompare :=
@ -732,23 +697,25 @@ implementation
*****************************************************************************}
constructor ttypenode.create(t : ttype);
begin
inherited create(typen);
restype:=t;
end;
function ttypenode.det_resulttype:tnode;
begin
result:=nil;
resulttype:=restype;
end;
function ttypenode.pass_1 : tnode;
begin
result:=nil;
end;
function ttypenode.docompare(p: tnode): boolean;
begin
docompare :=
@ -765,7 +732,10 @@ begin
end.
{
$Log$
Revision 1.11 2001-04-02 21:20:31 peter
Revision 1.12 2001-04-04 22:42:40 peter
* move constant folding into det_resulttype
Revision 1.11 2001/04/02 21:20:31 peter
* resulttype rewrite
Revision 1.10 2000/12/31 11:14:10 jonas

158
compiler/nmat.pas
View File

@ -83,6 +83,7 @@ implementation
var
t : tnode;
rd,ld : pdef;
rv,lv : tconstexprint;
begin
result:=nil;
resulttypepass(left);
@ -92,6 +93,31 @@ implementation
if codegenerror then
exit;
{ constant folding }
if is_constintnode(left) and is_constintnode(right) then
begin
rv:=tordconstnode(right).value;
lv:=tordconstnode(left).value;
{ check for division by zero }
if (rv=0) then
begin
Message(parser_e_division_by_zero);
{ recover }
rv:=1;
end;
case nodetype of
modn:
t:=genintconstnode(lv mod rv);
divn:
t:=genintconstnode(lv div rv);
end;
resulttypepass(t);
result:=t;
exit;
end;
{ allow operator overloading }
t:=self;
if isbinaryoverloaded(t) then
@ -166,8 +192,6 @@ implementation
function tmoddivnode.pass_1 : tnode;
var
t : tnode;
rv,lv : tconstexprint;
begin
result:=nil;
firstpass(left);
@ -175,30 +199,6 @@ implementation
if codegenerror then
exit;
if is_constintnode(left) and is_constintnode(right) then
begin
rv:=tordconstnode(right).value;
lv:=tordconstnode(left).value;
{ check for division by zero }
if (rv=0) then
begin
Message(parser_e_division_by_zero);
{ recover }
rv:=1;
end;
case nodetype of
modn:
t:=genintconstnode(lv mod rv);
divn:
t:=genintconstnode(lv div rv);
end;
firstpass(t);
result:=t;
exit;
end;
{ 64bit }
if (left.resulttype.def^.deftype=orddef) and (right.resulttype.def^.deftype=orddef) and
(is_64bitint(left.resulttype.def) or is_64bitint(right.resulttype.def)) then
@ -232,6 +232,20 @@ implementation
if codegenerror then
exit;
{ constant folding }
if is_constintnode(left) and is_constintnode(right) then
begin
case nodetype of
shrn:
t:=genintconstnode(tordconstnode(left).value shr tordconstnode(right).value);
shln:
t:=genintconstnode(tordconstnode(left).value shl tordconstnode(right).value);
end;
resulttypepass(t);
result:=t;
exit;
end;
{ allow operator overloading }
t:=self;
if isbinaryoverloaded(t) then
@ -265,19 +279,6 @@ implementation
if codegenerror then
exit;
if is_constintnode(left) and is_constintnode(right) then
begin
case nodetype of
shrn:
t:=genintconstnode(tordconstnode(left).value shr tordconstnode(right).value);
shln:
t:=genintconstnode(tordconstnode(left).value shl tordconstnode(right).value);
end;
firstpass(t);
result:=t;
exit;
end;
{ 64 bit ints have their own shift handling }
if not(is_64bitint(left.resulttype.def)) then
regs:=1
@ -311,8 +312,24 @@ implementation
set_varstate(left,true);
if codegenerror then
exit;
resulttype:=left.resulttype;
{ constant folding }
if is_constintnode(left) then
begin
tordconstnode(left).value:=-tordconstnode(left).value;
result:=left;
left:=nil;
exit;
end;
if is_constrealnode(left) then
begin
trealconstnode(left).value_real:=-trealconstnode(left).value_real;
result:=left;
left:=nil;
exit;
end;
resulttype:=left.resulttype;
if (left.resulttype.def^.deftype=floatdef) then
begin
end
@ -371,21 +388,6 @@ implementation
if codegenerror then
exit;
if is_constintnode(left) then
begin
t:=cordconstnode.create(-tordconstnode(left).value,resulttype);
firstpass(t);
result:=t;
exit;
end;
if is_constrealnode(left) then
begin
t:=crealconstnode.create(-trealconstnode(left).value_real,resulttype);
firstpass(t);
result:=t;
exit;
end;
registers32:=left.registers32;
registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
@ -436,6 +438,7 @@ implementation
var
t : tnode;
notdef : pprocdef;
v : tconstexprint;
begin
result:=nil;
resulttypepass(left);
@ -443,6 +446,29 @@ implementation
if codegenerror then
exit;
{ constant folding }
if (left.nodetype=ordconstn) then
begin
if is_boolean(left.resulttype.def) then
{ here we do a boolean(byte(..)) type cast because }
{ boolean(<int64>) is buggy in 1.00 }
t:=cordconstnode.create(byte(not(boolean(byte(tordconstnode(left).value)))),left.resulttype)
else
begin
v:=tordconstnode(left).value;
case left.resulttype.def^.size of
1 : v:=(not(v and $ff)) and $ff;
2 : v:=(not(v and $ffff)) and $ffff;
4 : v:=(not(v and $ffffffff)) and $ffffffff;
8 : v:=not(v);
end;
t:=cordconstnode.create(v,left.resulttype);
end;
resulttypepass(t);
result:=t;
exit;
end;
resulttype:=left.resulttype;
if is_boolean(resulttype.def) then
begin
@ -460,8 +486,6 @@ implementation
end
else if is_integer(left.resulttype.def) then
begin
if (porddef(left.resulttype.def)^.typ <> u32bit) then
inserttypeconv(left,s32bittype);
end
else
begin
@ -494,25 +518,10 @@ implementation
begin
result:=nil;
firstpass(left);
set_varstate(left,true);
if codegenerror then
exit;
if (left.nodetype=ordconstn) then
begin
if is_boolean(left.resulttype.def) then
{ here we do a boolena(byte(..)) type cast because }
{ boolean(<int64>) is buggy in 1.00 }
t:=cordconstnode.create(byte(not(boolean(byte(tordconstnode(left).value)))),left.resulttype)
else
t:=cordconstnode.create(not(tordconstnode(left).value),left.resulttype);
firstpass(t);
result:=t;
exit;
end;
location.loc:=left.location.loc;
resulttype:=left.resulttype;
registers32:=left.registers32;
{$ifdef SUPPORT_MMX}
registersmmx:=left.registersmmx;
@ -569,7 +578,10 @@ begin
end.
{
$Log$
Revision 1.17 2001-04-02 21:20:31 peter
Revision 1.18 2001-04-04 22:42:40 peter
* move constant folding into det_resulttype
Revision 1.17 2001/04/02 21:20:31 peter
* resulttype rewrite
Revision 1.16 2001/03/20 18:11:03 jonas