{ $Id$ Copyright (c) 1998-2000 by Florian Klaempfl Type checking and register allocation for add nodes This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. **************************************************************************** } unit nadd; {$i defines.inc} interface uses node; type taddnode = class(tbinopnode) constructor create(tt : tnodetype;l,r : tnode);override; function pass_1 : tnode;override; function det_resulttype:tnode;override; protected { override the following if you want to implement } { parts explicitely in the code generator (JM) } function first_addstring: tnode; virtual; function first_addset: tnode; virtual; { only implements "muln" nodes, the rest always has to be done in } { the code generator for performance reasons (JM) } function first_add64bitint: tnode; virtual; end; taddnodeclass = class of taddnode; var { caddnode is used to create nodes of the add type } { the virtual constructor allows to assign } { another class type to caddnode => processor } { specific node types can be created } caddnode : taddnodeclass; implementation uses globtype,systems, cutils,verbose,globals,widestr, symconst,symtype,symbase,symdef,symsym,symtable,types, cpuinfo, cgbase, htypechk,pass_1, nmat,ncnv,nld,ncon,nset,nopt,ncal,ninl, cpubase; {***************************************************************************** TADDNODE *****************************************************************************} {$ifdef fpc} {$maxfpuregisters 0} {$endif fpc} constructor taddnode.create(tt : tnodetype;l,r : tnode); begin inherited create(tt,l,r); end; function taddnode.det_resulttype:tnode; var hp,t : tnode; lt,rt : tnodetype; rd,ld : tdef; htype : ttype; ot : tnodetype; concatstrings : boolean; resultset : pconstset; i : longint; b : boolean; s1,s2 : pchar; ws1,ws2 : pcompilerwidestring; l1,l2 : longint; rv,lv : tconstexprint; rvd,lvd : bestreal; begin result:=nil; { first do the two subtrees } resulttypepass(left); resulttypepass(right); { both left and right need to be valid } set_varstate(left,true); set_varstate(right,true); if codegenerror then exit; { convert array constructors to sets, because there is no other operator possible for array constructors } if is_array_constructor(left.resulttype.def) then begin arrayconstructor_to_set(tarrayconstructornode(left)); resulttypepass(left); end; if is_array_constructor(right.resulttype.def) then begin arrayconstructor_to_set(tarrayconstructornode(right)); resulttypepass(right); end; { allow operator overloading } hp:=self; if isbinaryoverloaded(hp) then begin result:=hp; exit; end; { Kylix allows enum+ordconstn in an enum declaration (blocktype is bt_type), we need to do the conversion here before the constant folding } if (m_delphi in aktmodeswitches) and (blocktype=bt_type) then begin if (left.resulttype.def.deftype=enumdef) and (right.resulttype.def.deftype=orddef) then begin { insert explicit typecast to s32bit } left:=ctypeconvnode.create(left,s32bittype); include(left.flags,nf_explizit); resulttypepass(left); end else if (left.resulttype.def.deftype=orddef) and (right.resulttype.def.deftype=enumdef) then begin { insert explicit typecast to s32bit } right:=ctypeconvnode.create(right,s32bittype); include(right.flags,nf_explizit); resulttypepass(right); end; end; { is one a real float, then both need to be floats, this need to be done before the constant folding so constant operation on a float and int are also handled } if (right.resulttype.def.deftype=floatdef) or (left.resulttype.def.deftype=floatdef) then begin inserttypeconv(right,pbestrealtype^); inserttypeconv(left,pbestrealtype^); end; { if one operand is a widechar or a widestring, both operands } { are converted to widestring. This must be done before constant } { folding to allow char+widechar etc. } if is_widestring(right.resulttype.def) or is_widestring(left.resulttype.def) or is_widechar(right.resulttype.def) or is_widechar(left.resulttype.def) then begin inserttypeconv(right,cwidestringtype); inserttypeconv(left,cwidestringtype); end; { load easier access variables } rd:=right.resulttype.def; ld:=left.resulttype.def; 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 { 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 * tpointerdef(left.resulttype.def).pointertype.def.size; if (rt = pointerconstn) and (lt <> pointerconstn) then lv := lv * tpointerdef(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(lvrv),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 } rvd:=rv; lvd:=lv; if int(rvd)=0 then begin Message(parser_e_invalid_float_operation); t:=crealconstnode.create(0,pbestrealtype^); end else t:=crealconstnode.create(int(lvd)/int(rvd),pbestrealtype^); end; else CGMessage(type_e_mismatch); end; 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(lvdrvd),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; result:=t; exit; end; { first, we handle widestrings, so we can check later for } { stringconstn only } { widechars are converted above to widestrings too } { this isn't veryy efficient, but I don't think } { that it does matter that much (FK) } if (lt=stringconstn) and (rt=stringconstn) and (tstringconstnode(left).st_type=st_widestring) and (tstringconstnode(right).st_type=st_widestring) then begin initwidestring(ws1); initwidestring(ws2); copywidestring(pcompilerwidestring(tstringconstnode(left).value_str),ws1); copywidestring(pcompilerwidestring(tstringconstnode(right).value_str),ws2); case nodetype of addn : begin concatwidestrings(ws1,ws2); t:=cstringconstnode.createwstr(ws1); end; ltn : t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<0),booltype); lten : t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<=0),booltype); gtn : t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)>0),booltype); gten : t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)>=0),booltype); equaln : t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)=0),booltype); unequaln : t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<>0),booltype); end; donewidestring(ws1); donewidestring(ws2); 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); 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 { check types } inserttypeconv(left,right.resulttype); if codegenerror then begin { recover by only returning the left part } result:=left; left:=nil; exit; end; 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); result:=t; exit; end; { but an int/int gives real/real! } if nodetype=slashn then begin CGMessage(type_h_use_div_for_int); inserttypeconv(right,pbestrealtype^); inserttypeconv(left,pbestrealtype^); end { if both are orddefs then check sub types } else if (ld.deftype=orddef) and (rd.deftype=orddef) then begin { 2 booleans? Make them equal to the largest boolean } if is_boolean(ld) and is_boolean(rd) then begin if torddef(left.resulttype.def).size>torddef(right.resulttype.def).size then begin inserttypeconv(right,left.resulttype); ttypeconvnode(right).convtype:=tc_bool_2_int; include(right.flags,nf_explizit); end else if torddef(left.resulttype.def).size0); 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); 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); 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 begin if nodetype=addn then begin resulttype:=cshortstringtype; if not(is_constcharnode(left) and is_constcharnode(right)) then begin inserttypeconv(left,cshortstringtype); hp := genaddsstringcharoptnode(self); result := hp; exit; end; end; end { is there a signed 64 bit type ? } else if ((torddef(rd).typ=s64bit) or (torddef(ld).typ=s64bit)) then begin if (torddef(ld).typ<>s64bit) then inserttypeconv(left,cs64bittype); if (torddef(rd).typ<>s64bit) then inserttypeconv(right,cs64bittype); end { is there a unsigned 64 bit type ? } else if ((torddef(rd).typ=u64bit) or (torddef(ld).typ=u64bit)) then begin if (torddef(ld).typ<>u64bit) then inserttypeconv(left,cu64bittype); if (torddef(rd).typ<>u64bit) then inserttypeconv(right,cu64bittype); end { is there a cardinal? } else if ((torddef(rd).typ=u32bit) or (torddef(ld).typ=u32bit)) then begin if is_signed(ld) and { then rd = u32bit } { convert positive constants to u32bit } not(is_constintnode(left) and (tordconstnode(left).value >= 0)) and { range/overflow checking on mixed signed/cardinal expressions } { is only possible if you convert everything to 64bit (JM) } ((aktlocalswitches * [cs_check_overflow,cs_check_range] <> []) and (nodetype in [addn,subn,muln])) then begin { perform the operation in 64bit } CGMessage(type_w_mixed_signed_unsigned); inserttypeconv(left,cs64bittype); inserttypeconv(right,cs64bittype); end else begin if is_signed(ld) and not(is_constintnode(left) and (tordconstnode(left).value >= 0)) and (cs_check_range in aktlocalswitches) then CGMessage(type_w_mixed_signed_unsigned2); inserttypeconv(left,u32bittype); if is_signed(rd) and { then ld = u32bit } { convert positive constants to u32bit } not(is_constintnode(right) and (tordconstnode(right).value >= 0)) and ((aktlocalswitches * [cs_check_overflow,cs_check_range] <> []) and (nodetype in [addn,subn,muln])) then begin { perform the operation in 64bit } CGMessage(type_w_mixed_signed_unsigned); inserttypeconv(left,cs64bittype); inserttypeconv(right,cs64bittype); end else begin if is_signed(rd) and not(is_constintnode(right) and (tordconstnode(right).value >= 0)) and (cs_check_range in aktlocalswitches) then CGMessage(type_w_mixed_signed_unsigned2); inserttypeconv(right,u32bittype); end; end; end { generic ord conversion is s32bit } else begin inserttypeconv(right,s32bittype); inserttypeconv(left,s32bittype); end; end { if both are floatdefs, conversion is already done before constant folding } else if (ld.deftype=floatdef) then begin { already converted } end { left side a setdef, must be before string processing, else array constructor can be seen as array of char (PFV) } else if (ld.deftype=setdef) then begin { trying to add a set element? } if (nodetype=addn) and (rd.deftype<>setdef) then begin if (rt=setelementn) then begin if not(is_equal(tsetdef(ld).elementtype.def,rd)) then CGMessage(type_e_set_element_are_not_comp); end else CGMessage(type_e_mismatch) end else begin if not(nodetype in [addn,subn,symdifn,muln,equaln,unequaln,lten,gten]) then CGMessage(type_e_set_operation_unknown); { right def must be a also be set } if (rd.deftype<>setdef) or not(is_equal(rd,ld)) then CGMessage(type_e_set_element_are_not_comp); end; { ranges require normsets } if (tsetdef(ld).settype=smallset) and (rt=setelementn) and assigned(tsetelementnode(right).right) then begin { generate a temporary normset def, it'll be destroyed when the symtable is unloaded } htype.setdef(tsetdef.create(tsetdef(ld).elementtype,255)); inserttypeconv(left,htype); end; { if the destination is not a smallset then insert a typeconv which loads a smallset into a normal set } if (tsetdef(ld).settype<>smallset) and (tsetdef(rd).settype=smallset) then begin if (right.nodetype=setconstn) then begin t:=csetconstnode.create(tsetconstnode(right).value_set,left.resulttype); tsetconstnode(t).left:=tsetconstnode(right).left; tsetconstnode(right).left := nil; right.free; right:=t; end else inserttypeconv(right,left.resulttype); resulttypepass(right); end; end { compare pchar to char arrays by addresses like BP/Delphi } else if (is_pchar(ld) and is_chararray(rd)) or (is_pchar(rd) and is_chararray(ld)) then begin if is_chararray(rd) then inserttypeconv(right,left.resulttype) else inserttypeconv(left,right.resulttype); end { is one of the operands a string?, chararrays are also handled as strings (after conversion), also take care of chararray+chararray and chararray+char } else if (rd.deftype=stringdef) or (ld.deftype=stringdef) or ((is_chararray(rd) or is_char(rd)) and (is_chararray(ld) or is_char(ld))) then begin if is_widestring(rd) or is_widestring(ld) then begin if not(is_widestring(rd)) then inserttypeconv(right,cwidestringtype); if not(is_widestring(ld)) then inserttypeconv(left,cwidestringtype); end else if is_ansistring(rd) or is_ansistring(ld) then begin if not(is_ansistring(rd)) then inserttypeconv(right,cansistringtype); if not(is_ansistring(ld)) then inserttypeconv(left,cansistringtype); end else if is_longstring(rd) or is_longstring(ld) then begin if not(is_longstring(rd)) then inserttypeconv(right,clongstringtype); if not(is_longstring(ld)) then inserttypeconv(left,clongstringtype); location.loc:=LOC_MEM; end else begin if not(is_shortstring(ld)) then inserttypeconv(left,cshortstringtype); { don't convert char, that can be handled by the optimized node } if not(is_shortstring(rd) or is_char(rd)) then inserttypeconv(right,cshortstringtype); end; end { pointer comparision and subtraction } else if (rd.deftype=pointerdef) and (ld.deftype=pointerdef) then begin case nodetype of equaln,unequaln : begin if is_voidpointer(right.resulttype.def) then inserttypeconv(right,left.resulttype) else if is_voidpointer(left.resulttype.def) then inserttypeconv(left,right.resulttype) else if not(is_equal(ld,rd)) then CGMessage(type_e_mismatch); end; ltn,lten,gtn,gten: begin if (cs_extsyntax in aktmoduleswitches) then begin if is_voidpointer(right.resulttype.def) then inserttypeconv(right,left.resulttype) else if is_voidpointer(left.resulttype.def) then inserttypeconv(left,right.resulttype) else if not(is_equal(ld,rd)) then CGMessage(type_e_mismatch); end else CGMessage(type_e_mismatch); end; subn: begin if (cs_extsyntax in aktmoduleswitches) then begin if is_voidpointer(right.resulttype.def) then inserttypeconv(right,left.resulttype) else if is_voidpointer(left.resulttype.def) then inserttypeconv(left,right.resulttype) else if not(is_equal(ld,rd)) then CGMessage(type_e_mismatch); end else CGMessage(type_e_mismatch); resulttype:=s32bittype; exit; end; addn: begin if (cs_extsyntax in aktmoduleswitches) then begin if is_voidpointer(right.resulttype.def) then inserttypeconv(right,left.resulttype) else if is_voidpointer(left.resulttype.def) then inserttypeconv(left,right.resulttype) else if not(is_equal(ld,rd)) then CGMessage(type_e_mismatch); end else CGMessage(type_e_mismatch); resulttype:=s32bittype; exit; end; else CGMessage(type_e_mismatch); end; end { class or interface equation } else if is_class_or_interface(rd) or is_class_or_interface(ld) then begin if is_class_or_interface(rd) and is_class_or_interface(ld) then begin if tobjectdef(rd).is_related(tobjectdef(ld)) then inserttypeconv(right,left.resulttype) else inserttypeconv(left,right.resulttype); end else if is_class_or_interface(rd) then inserttypeconv(left,right.resulttype) else inserttypeconv(right,left.resulttype); if not(nodetype in [equaln,unequaln]) then CGMessage(type_e_mismatch); end else if (rd.deftype=classrefdef) and (ld.deftype=classrefdef) then begin if tobjectdef(tclassrefdef(rd).pointertype.def).is_related( tobjectdef(tclassrefdef(ld).pointertype.def)) then inserttypeconv(right,left.resulttype) else inserttypeconv(left,right.resulttype); if not(nodetype in [equaln,unequaln]) then CGMessage(type_e_mismatch); end { allows comperasion with nil pointer } else if is_class_or_interface(rd) or (rd.deftype=classrefdef) then begin inserttypeconv(left,right.resulttype); if not(nodetype in [equaln,unequaln]) then CGMessage(type_e_mismatch); end else if is_class_or_interface(ld) or (ld.deftype=classrefdef) then begin inserttypeconv(right,left.resulttype); if not(nodetype in [equaln,unequaln]) then CGMessage(type_e_mismatch); end { support procvar=nil,procvar<>nil } else if ((ld.deftype=procvardef) and (rt=niln)) or ((rd.deftype=procvardef) and (lt=niln)) then begin if not(nodetype in [equaln,unequaln]) then CGMessage(type_e_mismatch); end {$ifdef SUPPORT_MMX} { mmx support, this must be before the zero based array check } else if (cs_mmx in aktlocalswitches) and is_mmx_able_array(ld) and is_mmx_able_array(rd) and is_equal(ld,rd) then begin case nodetype of addn,subn,xorn,orn,andn: ; { mul is a little bit restricted } muln: if not(mmx_type(ld) in [mmxu16bit,mmxs16bit,mmxfixed16]) then CGMessage(type_e_mismatch); else CGMessage(type_e_mismatch); end; end {$endif SUPPORT_MMX} { this is a little bit dangerous, also the left type } { pointer to should be checked! This broke the mmx support } else if (rd.deftype=pointerdef) or is_zero_based_array(rd) then begin if is_zero_based_array(rd) then begin resulttype.setdef(tpointerdef.create(tarraydef(rd).elementtype)); inserttypeconv(right,resulttype); end; inserttypeconv(left,s32bittype); if nodetype=addn then begin if not(cs_extsyntax in aktmoduleswitches) or (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then CGMessage(type_e_mismatch); if (rd.deftype=pointerdef) and (tpointerdef(rd).pointertype.def.size>1) then left:=caddnode.create(muln,left,cordconstnode.create(tpointerdef(rd).pointertype.def.size,s32bittype)); end else CGMessage(type_e_mismatch); end else if (ld.deftype=pointerdef) or is_zero_based_array(ld) then begin if is_zero_based_array(ld) then begin resulttype.setdef(tpointerdef.create(tarraydef(ld).elementtype)); inserttypeconv(left,resulttype); end; inserttypeconv(right,s32bittype); if nodetype in [addn,subn] then begin if not(cs_extsyntax in aktmoduleswitches) or (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then CGMessage(type_e_mismatch); if (ld.deftype=pointerdef) and (tpointerdef(ld).pointertype.def.size>1) then right:=caddnode.create(muln,right,cordconstnode.create(tpointerdef(ld).pointertype.def.size,s32bittype)); end else CGMessage(type_e_mismatch); end else if (rd.deftype=procvardef) and (ld.deftype=procvardef) and is_equal(rd,ld) then begin if not (nodetype in [equaln,unequaln]) then CGMessage(type_e_mismatch); end { enums } else if (ld.deftype=enumdef) and (rd.deftype=enumdef) then begin if not(is_equal(ld,rd)) then inserttypeconv(right,left.resulttype); if not(nodetype in [equaln,unequaln,ltn,lten,gtn,gten]) then CGMessage(type_e_mismatch); end { generic conversion, this is for error recovery } else begin inserttypeconv(left,s32bittype); inserttypeconv(right,s32bittype); end; { set resulttype if not already done } if not assigned(resulttype.def) then begin case nodetype of ltn,lten,gtn,gten,equaln,unequaln : resulttype:=booltype; slashn : resulttype:=pbestrealtype^; addn: begin { for strings, return is always a 255 char string } if is_shortstring(left.resulttype.def) then resulttype:=cshortstringtype else resulttype:=left.resulttype; end; else resulttype:=left.resulttype; end; end; end; function taddnode.first_addstring: tnode; var p: tnode; begin { when we get here, we are sure that both the left and the right } { node are both strings of the same stringtype (JM) } case nodetype of addn: begin { note: if you implemented an fpc_shortstr_concat similar to the } { one in i386.inc, you have to override first_addstring like in } { ti386addnode.first_string and implement the shortstring concat } { manually! The generic routine is different from the i386 one (JM) } { create the call to the concat routine both strings as arguments } result := ccallnode.createintern('fpc_'+ lower(tstringdef(resulttype.def).stringtypname)+'_concat', ccallparanode.create(right,ccallparanode.create(left,nil))); { we reused the arguments } left := nil; right := nil; firstpass(result); end; ltn,lten,gtn,gten,equaln,unequaln : begin { generate better code for s='' and s<>'' } if (nodetype in [equaln,unequaln]) and (((left.nodetype=stringconstn) and (str_length(left)=0)) or ((right.nodetype=stringconstn) and (str_length(right)=0))) then begin { switch so that the constant is always on the right } if left.nodetype = stringconstn then begin p := left; left := right; right := p; end; if is_shortstring(left.resulttype.def) then { compare the length with 0 } result := caddnode.create(nodetype, cinlinenode.create(in_length_x,false,left), cordconstnode.create(0,s32bittype)) else begin { compare the pointer with nil (for ansistrings etc), } { faster than getting the length (JM) } result:= caddnode.create(nodetype, ctypeconvnode.create(left,voidpointertype), cpointerconstnode.create(0,voidpointertype)); taddnode(result).left.toggleflag(nf_explizit); end; { left is reused } left := nil; { right isn't } right.free; right := nil; firstpass(result); exit; end; { no string constant -> call compare routine } result := ccallnode.createintern('fpc_'+ lower(tstringdef(left.resulttype.def).stringtypname)+'_compare', ccallparanode.create(right,ccallparanode.create(left,nil))); { and compare its result with 0 according to the original operator } result := caddnode.create(nodetype,result, cordconstnode.create(0,s32bittype)); left := nil; right := nil; firstpass(result); end; end; end; function taddnode.first_addset: tnode; var procname: string[31]; tempn: tnode; paras: tcallparanode; srsym: ttypesym; createset: boolean; begin { get the sym that represents the fpc_normal_set type } if not searchsystype('FPC_NORMAL_SET',srsym) then internalerror(200108313); case nodetype of equaln,unequaln,lten,gten: begin case nodetype of equaln,unequaln: procname := 'fpc_set_comp_sets'; lten,gten: begin procname := 'fpc_set_contains_sets'; { (left >= right) = (right <= left) } if nodetype = gten then begin tempn := left; left := right; right := tempn; end; end; end; { convert the arguments (explicitely) to fpc_normal_set's } left := ctypeconvnode.create(left,srsym.restype); left.toggleflag(nf_explizit); right := ctypeconvnode.create(right,srsym.restype); right.toggleflag(nf_explizit); result := ccallnode.createintern(procname,ccallparanode.create(right, ccallparanode.create(left,nil))); { left and right are reused as parameters } left := nil; right := nil; { for an unequaln, we have to negate the result of comp_sets } if nodetype = unequaln then result := cnotnode.create(result); end; addn: begin { optimize first loading of a set } if (right.nodetype=setelementn) and not(assigned(tsetelementnode(right).right)) and is_emptyset(left) then begin { type cast the value to pass as argument to a byte, } { since that's what the helper expects } tsetelementnode(right).left := ctypeconvnode.create(tsetelementnode(right).left,u8bittype); tsetelementnode(right).left.toggleflag(nf_explizit); { set the resulttype to the actual one (otherwise it's } { "fpc_normal_set") } result := ccallnode.createinternres('fpc_set_create_element', ccallparanode.create(tsetelementnode(right).left,nil), resulttype); { reused } tsetelementnode(right).left := nil; end else begin if right.nodetype=setelementn then begin { convert the arguments to bytes, since that's what } { the helper expects } tsetelementnode(right).left := ctypeconvnode.create(tsetelementnode(right).left, u8bittype); tsetelementnode(right).left.toggleflag(nf_explizit); { convert the original set (explicitely) to an } { fpc_normal_set so we can pass it to the helper } left := ctypeconvnode.create(left,srsym.restype); left.toggleflag(nf_explizit); { add a range or a single element? } if assigned(tsetelementnode(right).right) then begin tsetelementnode(right).right := ctypeconvnode.create(tsetelementnode(right).right, u8bittype); tsetelementnode(right).right.toggleflag(nf_explizit); { create the call } result := ccallnode.createinternres('fpc_set_set_range', ccallparanode.create(tsetelementnode(right).right, ccallparanode.create(tsetelementnode(right).left, ccallparanode.create(left,nil))),resulttype); end else begin result := ccallnode.createinternres('fpc_set_set_byte', ccallparanode.create(tsetelementnode(right).left, ccallparanode.create(left,nil)),resulttype); end; { remove reused parts from original node } tsetelementnode(right).right := nil; tsetelementnode(right).left := nil; left := nil; end else begin { add two sets } { convert the sets to fpc_normal_set's } left := ctypeconvnode.create(left,srsym.restype); left.toggleflag(nf_explizit); right := ctypeconvnode.create(right,srsym.restype); right.toggleflag(nf_explizit); result := ccallnode.createinternres('fpc_set_add_sets', ccallparanode.create(right, ccallparanode.create(left,nil)),resulttype); { remove reused parts from original node } left := nil; right := nil; end; end end; subn,symdifn,muln: begin { convert the sets to fpc_normal_set's } left := ctypeconvnode.create(left,srsym.restype); left.toggleflag(nf_explizit); right := ctypeconvnode.create(right,srsym.restype); right.toggleflag(nf_explizit); paras := ccallparanode.create(right, ccallparanode.create(left,nil)); case nodetype of subn: result := ccallnode.createinternres('fpc_set_sub_sets', paras,resulttype); symdifn: result := ccallnode.createinternres('fpc_set_symdif_sets', paras,resulttype); muln: result := ccallnode.createinternres('fpc_set_mul_sets', paras,resulttype); end; { remove reused parts from original node } left := nil; right := nil; end; else internalerror(200108311); end; firstpass(result); end; function taddnode.first_add64bitint: tnode; var procname: string[31]; temp: tnode; power: longint; begin result := nil; { create helper calls mul } if nodetype <> muln then exit; { make sure that if there is a constant, that it's on the right } if left.nodetype = ordconstn then begin temp := right; right := left; left := temp; end; { can we use a shift instead of a mul? } if (right.nodetype = ordconstn) and ispowerof2(tordconstnode(right).value,power) then begin tordconstnode(right).value := power; result := cshlshrnode.create(shln,left,right); { left and right are reused } left := nil; right := nil; { return firstpassed new node } firstpass(result); exit; end; { otherwise, create the parameters for the helper } right := ccallparanode.create( cordconstnode.create(ord(cs_check_overflow in aktlocalswitches),booltype), ccallparanode.create(right,ccallparanode.create(left,nil))); left := nil; if torddef(resulttype.def).typ = s64bit then procname := 'fpc_mul_int64' else procname := 'fpc_mul_qword'; result := ccallnode.createintern(procname,right); right := nil; firstpass(result); end; function taddnode.pass_1 : tnode; var hp : tnode; lt,rt : tnodetype; rd,ld : tdef; begin result:=nil; { first do the two subtrees } firstpass(left); firstpass(right); if codegenerror then exit; { load easier access variables } rd:=right.resulttype.def; ld:=left.resulttype.def; rt:=right.nodetype; lt:=left.nodetype; { int/int gives real/real! } if nodetype=slashn then begin { maybe we need an integer register to save } { a reference } if ((left.location.loc<>LOC_FPU) or (right.location.loc<>LOC_FPU)) and (left.registers32=right.registers32) then calcregisters(self,1,1,0) else calcregisters(self,0,1,0); location.loc:=LOC_FPU; end { if both are orddefs then check sub types } else if (ld.deftype=orddef) and (rd.deftype=orddef) then begin { 2 booleans ? } if is_boolean(ld) and is_boolean(rd) then begin 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 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 } if is_char(ld) then begin if nodetype=addn then internalerror(200103291); calcregisters(self,1,0,0); end { is there a 64 bit type ? } else if (torddef(ld).typ in [s64bit,u64bit]) then begin result := first_add64bitint; if assigned(result) then exit; calcregisters(self,2,0,0) end { is there a cardinal? } else if (torddef(ld).typ=u32bit) then begin calcregisters(self,1,0,0); { for unsigned mul we need an extra register } if nodetype=muln then inc(registers32); end { generic s32bit conversion } else calcregisters(self,1,0,0); end { left side a setdef, must be before string processing, else array constructor can be seen as array of char (PFV) } else if (ld.deftype=setdef) then begin if tsetdef(ld).settype=smallset then begin { are we adding set elements ? } if right.nodetype=setelementn then calcregisters(self,2,0,0) else calcregisters(self,1,0,0); location.loc:=LOC_REGISTER; end else begin result := first_addset; if assigned(result) then exit; calcregisters(self,0,0,0); { here we call SET... } procinfo^.flags:=procinfo^.flags or pi_do_call; location.loc:=LOC_MEM; end; end { compare pchar by addresses like BP/Delphi } else if is_pchar(ld) then begin location.loc:=LOC_REGISTER; calcregisters(self,1,0,0); end { is one of the operands a string } else if (ld.deftype=stringdef) then begin if is_widestring(ld) then begin { we use reference counted widestrings so no fast exit here } procinfo^.no_fast_exit:=true; { this is only for add, the comparisaion is handled later } location.loc:=LOC_REGISTER; end else if is_ansistring(ld) then begin { we use ansistrings so no fast exit here } procinfo^.no_fast_exit:=true; { this is only for add, the comparisaion is handled later } location.loc:=LOC_REGISTER; end else if is_longstring(ld) then begin { this is only for add, the comparisaion is handled later } location.loc:=LOC_MEM; end else begin if canbeaddsstringcharoptnode(self) then begin hp := genaddsstringcharoptnode(self); firstpass(hp); pass_1 := hp; exit; end else begin { Fix right to be shortstring } if is_char(right.resulttype.def) then begin inserttypeconv(right,cshortstringtype); firstpass(right); end; end; if canbeaddsstringcsstringoptnode(self) then begin hp := genaddsstringcsstringoptnode(self); firstpass(hp); pass_1 := hp; exit; end; end; { otherwise, let addstring convert everything } result := first_addstring; exit; end { is one a real float ? } else if (rd.deftype=floatdef) or (ld.deftype=floatdef) then begin calcregisters(self,0,1,0); location.loc:=LOC_FPU; end { pointer comperation and subtraction } else if (ld.deftype=pointerdef) then begin location.loc:=LOC_REGISTER; calcregisters(self,1,0,0); end else if is_class_or_interface(ld) then begin location.loc:=LOC_REGISTER; calcregisters(self,1,0,0); end else if (ld.deftype=classrefdef) then begin location.loc:=LOC_REGISTER; calcregisters(self,1,0,0); end { support procvar=nil,procvar<>nil } else if ((ld.deftype=procvardef) and (rt=niln)) or ((rd.deftype=procvardef) and (lt=niln)) then begin calcregisters(self,1,0,0); location.loc:=LOC_REGISTER; end {$ifdef SUPPORT_MMX} { mmx support, this must be before the zero based array check } else if (cs_mmx in aktlocalswitches) and is_mmx_able_array(ld) and is_mmx_able_array(rd) then begin location.loc:=LOC_MMXREGISTER; calcregisters(self,0,0,1); end {$endif SUPPORT_MMX} else if (rd.deftype=pointerdef) or (ld.deftype=pointerdef) then begin location.loc:=LOC_REGISTER; calcregisters(self,1,0,0); end else if (rd.deftype=procvardef) and (ld.deftype=procvardef) and is_equal(rd,ld) then begin calcregisters(self,1,0,0); location.loc:=LOC_REGISTER; end else if (ld.deftype=enumdef) then begin calcregisters(self,1,0,0); end {$ifdef SUPPORT_MMX} else if (cs_mmx in aktlocalswitches) and is_mmx_able_array(ld) and is_mmx_able_array(rd) then begin location.loc:=LOC_MMXREGISTER; calcregisters(self,0,0,1); end {$endif SUPPORT_MMX} { the general solution is to convert to 32 bit int } else begin calcregisters(self,1,0,0); location.loc:=LOC_REGISTER; end; case nodetype of ltn,lten,gtn,gten,equaln,unequaln: begin if is_64bitint(left.resulttype.def) then location.loc:=LOC_JUMP else location.loc:=LOC_FLAGS; end; xorn: begin location.loc:=LOC_REGISTER; end; end; end; begin caddnode:=taddnode; end. { $Log$ Revision 1.39 2001-09-05 15:22:09 jonas * made multiplying, dividing and mod'ing of int64 and qword processor independent with compilerprocs (+ small optimizations by using shift/and where possible) Revision 1.38 2001/09/04 11:38:54 jonas + searchsystype() and searchsystype() functions in symtable * changed ninl and nadd to use these functions * i386 set comparison functions now return their results in al instead of in the flags so that they can be sued as compilerprocs - removed all processor specific code from n386add.pas that has to do with set handling, it's now all done in nadd.pas * fixed fpc_set_contains_sets in genset.inc * fpc_set_in_byte is now coded inline in n386set.pas and doesn't use a helper anymore * some small fixes in compproc.inc/set.inc regarding the declaration of internal helper types (fpc_small_set and fpc_normal_set) Revision 1.37 2001/09/03 13:27:42 jonas * compilerproc implementation of set addition/substraction/... * changed the declaration of some set helpers somewhat to accomodate the above change * i386 still uses the old code for comparisons of sets, because its helpers return the results in the flags * dummy tc_normal_2_small_set type conversion because I need the original resulttype of the set add nodes NOTE: you have to start a cycle with 1.0.5! Revision 1.36 2001/09/02 21:12:06 peter * move class of definitions into type section for delphi Revision 1.35 2001/08/31 15:42:15 jonas * added missing type conversion from small to normal sets Revision 1.34 2001/08/30 15:43:14 jonas * converted adding/comparing of strings to compileproc. Note that due to the way the shortstring helpers for i386 are written, they are still handled by the old code (reason: fpc_shortstr_compare returns results in the flags instead of in eax and fpc_shortstr_concat has wierd parameter conventions). The compilerproc stuff should work fine with the generic implementations though. * removed some nested comments warnings Revision 1.33 2001/08/26 13:36:38 florian * some cg reorganisation * some PPC updates Revision 1.32 2001/08/06 21:40:46 peter * funcret moved from tprocinfo to tprocdef Revision 1.31 2001/07/08 21:00:14 peter * various widestring updates, it works now mostly without charset mapping supported Revision 1.30 2001/06/04 21:41:26 peter * readded generic conversion to s32bit that i removed yesterday. It is still used for error recovery, added a small note about that Revision 1.29 2001/06/04 18:13:53 peter * Support kylix hack of having enum+integer in a enum declaration. Revision 1.28 2001/05/27 14:30:55 florian + some widestring stuff added Revision 1.27 2001/05/19 21:11:50 peter * first check for overloaded operator before doing inserting any typeconvs Revision 1.26 2001/05/19 12:53:52 peter * check set types when doing constant set evaluation Revision 1.25 2001/04/13 01:22:08 peter * symtable change to classes * range check generation and errors fixed, make cycle DEBUG=1 works * memory leaks fixed 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 * fixed web bug 1377 & const pointer arithmtic Revision 1.21 2001/01/14 22:13:13 peter * constant calculation fixed. The type of the new constant is now defined after the calculation is done. This should remove a lot of wrong warnings (and errors with -Cr). Revision 1.20 2000/12/31 11:14:10 jonas + implemented/fixed docompare() mathods for all nodes (not tested) + nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings and constant strings/chars together * n386add.pas: don't copy temp strings (of size 256) to another temp string when adding Revision 1.19 2000/12/16 15:55:32 jonas + warning when there is a chance to get a range check error because of automatic type conversion to u32bit * arithmetic operations with a cardinal and a signed operand are carried out in 64bit when range checking is on ("merged" from fixes branch) Revision 1.18 2000/11/29 00:30:31 florian * unused units removed from uses clause * some changes for widestrings Revision 1.17 2000/11/20 15:30:42 jonas * changed types of values used for constant expression evaluation to tconstexprint Revision 1.16 2000/11/13 11:30:55 florian * some bugs with interfaces and NIL fixed Revision 1.15 2000/11/04 14:25:20 florian + merged Attila's changes for interfaces, not tested yet Revision 1.14 2000/10/31 22:02:47 peter * symtable splitted, no real code changes Revision 1.13 2000/10/14 10:14:50 peter * moehrendorf oct 2000 rewrite Revision 1.12 2000/10/01 19:48:23 peter * lot of compile updates for cg11 Revision 1.11 2000/09/30 16:08:45 peter * more cg11 updates Revision 1.10 2000/09/28 19:49:52 florian *** empty log message *** Revision 1.9 2000/09/27 21:33:22 florian * finally nadd.pas compiles Revision 1.8 2000/09/27 20:25:44 florian * more stuff fixed Revision 1.7 2000/09/27 18:14:31 florian * fixed a lot of syntax errors in the n*.pas stuff Revision 1.6 2000/09/24 15:06:19 peter * use defines.inc Revision 1.5 2000/09/22 22:42:52 florian * more fixes Revision 1.4 2000/09/21 12:22:42 jonas * put piece of code between -dnewoptimizations2 since it wasn't necessary otherwise + support for full boolean evaluation (from tcadd) Revision 1.3 2000/09/20 21:50:59 florian * updated Revision 1.2 2000/08/29 08:24:45 jonas * some modifications to -dcardinalmulfix code Revision 1.1 2000/08/26 12:24:20 florian * initial release }