From a62eb86cde9a121a71121bbdffd00287199ad25d Mon Sep 17 00:00:00 2001 From: peter Date: Thu, 26 Nov 1998 13:10:39 +0000 Subject: [PATCH] * new int - int conversion -dNEWCNV * some function renamings --- compiler/cg386cnv.pas | 735 ++++++++++++++++++++++++------------------ compiler/cg386inl.pas | 10 +- compiler/htypechk.pas | 81 +++-- compiler/tccnv.pas | 94 ++++-- compiler/tree.pas | 208 +++++++----- 5 files changed, 683 insertions(+), 445 deletions(-) diff --git a/compiler/cg386cnv.pas b/compiler/cg386cnv.pas index 32670d4f76..dec9a8562b 100644 --- a/compiler/cg386cnv.pas +++ b/compiler/cg386cnv.pas @@ -46,7 +46,96 @@ implementation SecondTypeConv *****************************************************************************} - procedure maybe_rangechecking(p : ptree;p2,p1 : pdef); + type + tsecondconvproc = procedure(pto,pfrom : ptree;convtyp : tconverttype); + +{$ifdef NEWCNV} + + procedure second_int_to_int(pto,pfrom : ptree;convtyp : tconverttype); + var + op : tasmop; + opsize : topsize; + hregister : tregister; + begin + { is the result size smaller ? } + if pto^.resulttype^.sizepfrom^.resulttype^.size then + begin + { remove reference } + if not(pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then + begin + del_reference(pfrom^.location.reference); + { we can do this here as we need no temp inside } + ungetiftemp(pfrom^.location.reference); + end; + + { get op and opsize, handle separate for constants, becuase + movz doesn't support constant values } + if (pfrom^.location.loc=LOC_MEM) and (pfrom^.location.reference.isintvalue) then + begin + opsize:=def_opsize(pto^.resulttype); + op:=A_MOV; + end + else + begin + opsize:=def2def_opsize(pfrom^.resulttype,pto^.resulttype); + if opsize in [S_B,S_W,S_L] then + op:=A_MOV + else + if is_signed(pfrom^.resulttype) then + op:=A_MOVSX + else + op:=A_MOVZX; + end; + { load the register we need } + if pfrom^.location.loc<>LOC_REGISTER then + hregister:=getregister32 + else + hregister:=pfrom^.location.register; + { set the correct register size and location } + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + case pto^.resulttype^.size of + 1 : pto^.location.register:=makereg8(hregister); + 2 : pto^.location.register:=makereg16(hregister); + 4 : pto^.location.register:=makereg32(hregister); + end; + { insert the assembler code } + if pfrom^.location.loc in [LOC_CREGISTER,LOC_REGISTER] then + emit_reg_reg(op,opsize,pfrom^.location.register,pto^.location.register) + else + exprasmlist^.concat(new(pai386,op_ref_reg(op,opsize, + newreference(pfrom^.location.reference),pto^.location.register))); + { insert range check if necessary } + emitrangecheck(pto,pto^.resulttype); + end + + { the result size is equal } + else + begin + { insert range check if necessary } + emitrangecheck(pto,pto^.resulttype); + end; + end; + +{$else} + + procedure maybe_rangechecking(p : ptree;p2,p1 : pdef); { produces if necessary rangecheckcode } @@ -72,22 +161,22 @@ implementation (porddef(p2)^.typ=u32bit)) then begin porddef(p1)^.genrangecheck; - is_register:=(p^.left^.location.loc=LOC_REGISTER) or - (p^.left^.location.loc=LOC_CREGISTER); + is_register:=(p^.location.loc=LOC_REGISTER) or + (p^.location.loc=LOC_CREGISTER); if porddef(p2)^.typ=u8bit then begin if is_register then - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,p^.left^.location.register,R_EDI))) + exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,p^.location.register,R_EDI))) else - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.left^.location.reference),R_EDI))); + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.location.reference),R_EDI))); hregister:=R_EDI; end else if porddef(p2)^.typ=s8bit then begin if is_register then - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_BL,p^.left^.location.register,R_EDI))) + exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_BL,p^.location.register,R_EDI))) else - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_BL,newreference(p^.left^.location.reference),R_EDI))); + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_BL,newreference(p^.location.reference),R_EDI))); hregister:=R_EDI; end { rangechecking for u32bit ?? !!!!!!} @@ -98,24 +187,24 @@ implementation hregister:=p^.location.register else begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),R_EDI))); + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),R_EDI))); hregister:=R_EDI; end; end else if porddef(p2)^.typ=u16bit then begin if is_register then - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,p^.left^.location.register,R_EDI))) + exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,p^.location.register,R_EDI))) else - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.left^.location.reference),R_EDI))); + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.location.reference),R_EDI))); hregister:=R_EDI; end else if porddef(p2)^.typ=s16bit then begin if is_register then - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_WL,p^.left^.location.register,R_EDI))) + exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_WL,p^.location.register,R_EDI))) else - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_WL,newreference(p^.left^.location.reference),R_EDI))); + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_WL,newreference(p^.location.reference),R_EDI))); hregister:=R_EDI; end else internalerror(6); @@ -138,21 +227,18 @@ implementation exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hp))); emitl(A_LABEL,poslabel); end; - end; end; - type - tsecondconvproc = procedure(p,hp : ptree;convtyp : tconverttype); - procedure second_only_rangecheck(p,hp : ptree;convtyp : tconverttype); + procedure second_only_rangecheck(pto,pfrom : ptree;convtyp : tconverttype); begin - maybe_rangechecking(p,hp^.resulttype,p^.resulttype); + maybe_rangechecking(pto,pfrom^.resulttype,pto^.resulttype); end; - procedure second_smaller(p,hp : ptree;convtyp : tconverttype); + procedure second_smaller(pto,pfrom : ptree;convtyp : tconverttype); var hregister,destregister : tregister; @@ -164,74 +250,76 @@ implementation { problems with enums !! } if (cs_check_range in aktlocalswitches) and { with $R+ explicit type conversations in TP aren't range checked! } - (not(p^.explizit) {or not(cs_tp_compatible in aktmoduleswitches)}) and - (p^.resulttype^.deftype=orddef) and - (hp^.resulttype^.deftype=orddef) then + (not(pto^.explizit) {or not(cs_tp_compatible in aktmoduleswitches)}) and + (pto^.resulttype^.deftype=orddef) and + (pfrom^.resulttype^.deftype=orddef) then begin - if porddef(hp^.resulttype)^.typ=u32bit then + if porddef(pfrom^.resulttype)^.typ=u32bit then begin { when doing range checking for u32bit, we have some trouble } { because BOUND assumes signed values } { first, we check if the values is greater than 2^31: } { the u32bit rangenr contains the appropriate rangenr } - porddef(hp^.resulttype)^.genrangecheck; + porddef(pfrom^.resulttype)^.genrangecheck; hregister:=R_EDI; - if (p^.location.loc=LOC_REGISTER) or - (p^.location.loc=LOC_CREGISTER) then - hregister:=p^.location.register + if (pto^.location.loc=LOC_REGISTER) or + (pto^.location.loc=LOC_CREGISTER) then + hregister:=pto^.location.register else exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.location.reference),R_EDI))); + newreference(pto^.location.reference),R_EDI))); hpp:=new_reference(R_NO,0); - hpp^.symbol:=stringdup(porddef(hp^.resulttype)^.getrangecheckstring); + hpp^.symbol:=stringdup(porddef(pfrom^.resulttype)^.getrangecheckstring); exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hpp))); { then we do a normal range check } - porddef(p^.resulttype)^.genrangecheck; + porddef(pto^.resulttype)^.genrangecheck; hpp:=new_reference(R_NO,0); - hpp^.symbol:=stringdup(porddef(p^.resulttype)^.getrangecheckstring); + hpp^.symbol:=stringdup(porddef(pto^.resulttype)^.getrangecheckstring); exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hpp))); end else - if ((porddef(p^.resulttype)^.low>porddef(hp^.resulttype)^.low) or - (porddef(p^.resulttype)^.highporddef(pfrom^.resulttype)^.low) or + (porddef(pto^.resulttype)^.highLOC_CREGISTER) then + is_register:=pfrom^.location.loc=LOC_REGISTER; + if not(is_register) and (pfrom^.location.loc<>LOC_CREGISTER) then begin - del_reference(p^.left^.location.reference); + del_reference(pfrom^.location.reference); { we can do this here as we need no temp inside second_bigger } - ungetiftemp(p^.left^.location.reference); + ungetiftemp(pfrom^.location.reference); end; { this is wrong !!! gives me movl (%eax),%eax for the length(string !!! use only for constant values } {Constant cannot be loaded into registers using MOVZX!} - if (p^.left^.location.loc<>LOC_MEM) or (not p^.left^.location.reference.isintvalue) then + if (pfrom^.location.loc<>LOC_MEM) or (not pfrom^.location.reference.isintvalue) then case convtyp of tc_u8bit_2_s32bit,tc_u8bit_2_u32bit : begin if is_register then - hregister:=reg8toreg32(p^.left^.location.register) + hregister:=reg8toreg32(pfrom^.location.register) else hregister:=getregister32; op:=A_MOVZX; opsize:=S_BL; @@ -308,7 +396,7 @@ implementation tc_s8bit_2_s32bit,tc_s8bit_2_u32bit : begin if is_register then - hregister:=reg8toreg32(p^.left^.location.register) + hregister:=reg8toreg32(pfrom^.location.register) else hregister:=getregister32; op:=A_MOVSX; opsize:=S_BL; @@ -316,7 +404,7 @@ implementation tc_u16bit_2_s32bit,tc_u16bit_2_u32bit : begin if is_register then - hregister:=reg16toreg32(p^.left^.location.register) + hregister:=reg16toreg32(pfrom^.location.register) else hregister:=getregister32; op:=A_MOVZX; opsize:=S_WL; @@ -324,7 +412,7 @@ implementation tc_s16bit_2_s32bit,tc_s16bit_2_u32bit : begin if is_register then - hregister:=reg16toreg32(p^.left^.location.register) + hregister:=reg16toreg32(pfrom^.location.register) else hregister:=getregister32; op:=A_MOVSX; opsize:=S_WL; @@ -334,7 +422,7 @@ implementation tc_u8bit_2_u16bit : begin if is_register then - hregister:=reg8toreg16(p^.left^.location.register) + hregister:=reg8toreg16(pfrom^.location.register) else hregister:=reg32toreg16(getregister32); op:=A_MOVZX; opsize:=S_BW; @@ -342,7 +430,7 @@ implementation tc_s8bit_2_s16bit : begin if is_register then - hregister:=reg8toreg16(p^.left^.location.register) + hregister:=reg8toreg16(pfrom^.location.register) else hregister:=reg32toreg16(getregister32); op:=A_MOVSX; opsize:=S_BW; @@ -375,38 +463,41 @@ implementation end; if is_register then begin - emit_reg_reg(op,opsize,p^.left^.location.register,hregister); + emit_reg_reg(op,opsize,pfrom^.location.register,hregister); end else begin - if p^.left^.location.loc=LOC_CREGISTER then - emit_reg_reg(op,opsize,p^.left^.location.register,hregister) + if pfrom^.location.loc=LOC_CREGISTER then + emit_reg_reg(op,opsize,pfrom^.location.register,hregister) else exprasmlist^.concat(new(pai386,op_ref_reg(op,opsize, - newreference(p^.left^.location.reference),hregister))); + newreference(pfrom^.location.reference),hregister))); end; - clear_location(p^.location); - p^.location.loc:=LOC_REGISTER; - p^.location.register:=hregister; - maybe_rangechecking(p,p^.left^.resulttype,p^.resulttype); + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + pto^.location.register:=hregister; + maybe_rangechecking(pto,pfrom^.resulttype,pto^.resulttype); end; - procedure second_string_string(p,hp : ptree;convtyp : tconverttype); +{$endif NEWCNV} + + procedure second_string_to_string(pto,pfrom : ptree;convtyp : tconverttype); var pushed : tpushed; begin { does anybody know a better solution than this big case statement ? } { ok, a proc table would do the job } - case pstringdef(p^.resulttype)^.string_typ of + case pstringdef(pto^.resulttype)^.string_typ of st_shortstring: - case pstringdef(p^.left^.resulttype)^.string_typ of + case pstringdef(pfrom^.resulttype)^.string_typ of st_shortstring: begin - stringdispose(p^.location.reference.symbol); - gettempofsizereference(p^.resulttype^.size,p^.location.reference); - del_reference(p^.left^.location.reference); - copyshortstring(p^.location.reference,p^.left^.location.reference,pstringdef(p^.resulttype)^.len,false); - ungetiftemp(p^.left^.location.reference); + stringdispose(pto^.location.reference.symbol); + gettempofsizereference(pto^.resulttype^.size,pto^.location.reference); + del_reference(pfrom^.location.reference); + copyshortstring(pto^.location.reference,pfrom^.location.reference, + pstringdef(pto^.resulttype)^.len,false); + ungetiftemp(pfrom^.location.reference); end; st_longstring: begin @@ -415,8 +506,8 @@ implementation end; st_ansistring: begin - gettempofsizereference(p^.resulttype^.size,p^.location.reference); - loadansi2short(p^.left,p); + gettempofsizereference(pto^.resulttype^.size,pto^.location.reference); + loadansi2short(pfrom,pto); end; st_widestring: begin @@ -426,7 +517,7 @@ implementation end; st_longstring: - case pstringdef(p^.left^.resulttype)^.string_typ of + case pstringdef(pfrom^.resulttype)^.string_typ of st_shortstring: begin {!!!!!!!} @@ -445,14 +536,14 @@ implementation end; st_ansistring: - case pstringdef(p^.left^.resulttype)^.string_typ of + case pstringdef(pfrom^.resulttype)^.string_typ of st_shortstring: begin - gettempofsizereference(p^.resulttype^.size,p^.location.reference); - exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L,0,newreference(p^.location.reference)))); + gettempofsizereference(pto^.resulttype^.size,pto^.location.reference); + exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L,0,newreference(pto^.location.reference)))); pushusedregisters(pushed,$ff); - emit_push_lea_loc(p^.left^.location); - emit_push_lea_loc(p^.location); + emit_push_lea_loc(pfrom^.location); + emit_push_lea_loc(pto^.location); emitcall('FPC_SHORTSTR_TO_ANSISTR',true); maybe_loadesi; popusedregisters(pushed); @@ -470,7 +561,7 @@ implementation end; st_widestring: - case pstringdef(p^.left^.resulttype)^.string_typ of + case pstringdef(pfrom^.resulttype)^.string_typ of st_shortstring: begin {!!!!!!!} @@ -496,123 +587,121 @@ implementation end; - procedure second_cstring_charpointer(p,hp : ptree;convtyp : tconverttype); + procedure second_cstring_to_pchar(pto,pfrom : ptree;convtyp : tconverttype); begin - clear_location(p^.location); - p^.location.loc:=LOC_REGISTER; - p^.location.register:=getregister32; - inc(p^.left^.location.reference.offset); - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference), - p^.location.register))); + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + pto^.location.register:=getregister32; + inc(pfrom^.location.reference.offset); + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(pfrom^.location.reference), + pto^.location.register))); end; - procedure second_string_chararray(p,hp : ptree;convtyp : tconverttype); + procedure second_string_to_chararray(pto,pfrom : ptree;convtyp : tconverttype); begin - inc(p^.location.reference.offset); + inc(pto^.location.reference.offset); end; - procedure second_array_to_pointer(p,hp : ptree;convtyp : tconverttype); + procedure second_array_to_pointer(pto,pfrom : ptree;convtyp : tconverttype); begin - del_reference(p^.left^.location.reference); - clear_location(p^.location); - p^.location.loc:=LOC_REGISTER; - p^.location.register:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference), - p^.location.register))); + del_reference(pfrom^.location.reference); + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + pto^.location.register:=getregister32; + exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(pfrom^.location.reference), + pto^.location.register))); end; - procedure second_pointer_to_array(p,hp : ptree;convtyp : tconverttype); + procedure second_pointer_to_array(pto,pfrom : ptree;convtyp : tconverttype); begin - clear_location(p^.location); - p^.location.loc:=LOC_REFERENCE; - clear_reference(p^.location.reference); - if p^.left^.location.loc=LOC_REGISTER then - p^.location.reference.base:=p^.left^.location.register + clear_location(pto^.location); + pto^.location.loc:=LOC_REFERENCE; + clear_reference(pto^.location.reference); + case pfrom^.location.loc of + LOC_REGISTER : + pto^.location.reference.base:=pfrom^.location.register; + LOC_CREGISTER : + begin + pto^.location.reference.base:=getregister32; + emit_reg_reg(A_MOV,S_L,pfrom^.location.register,pto^.location.reference.base); + end else - begin - if p^.left^.location.loc=LOC_CREGISTER then - begin - p^.location.reference.base:=getregister32; - emit_reg_reg(A_MOV,S_L,p^.left^.location.register, - p^.location.reference.base); - end - else - begin - del_reference(p^.left^.location.reference); - p^.location.reference.base:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), - p^.location.reference.base))); - end; - end; + begin + del_reference(pfrom^.location.reference); + pto^.location.reference.base:=getregister32; + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference), + pto^.location.reference.base))); + end; + end; end; { generates the code for the type conversion from an array of char } { to a string } - procedure second_chararray_to_string(p,hp : ptree;convtyp : tconverttype); + procedure second_chararray_to_string(pto,pfrom : ptree;convtyp : tconverttype); var l : longint; begin { this is a type conversion which copies the data, so we can't } { return a reference } - clear_location(p^.location); - p^.location.loc:=LOC_MEM; + clear_location(pto^.location); + pto^.location.loc:=LOC_MEM; { first get the memory for the string } - gettempofsizereference(256,p^.location.reference); + gettempofsizereference(256,pto^.location.reference); { calc the length of the array } - l:=parraydef(p^.left^.resulttype)^.highrange- - parraydef(p^.left^.resulttype)^.lowrange+1; + l:=parraydef(pfrom^.resulttype)^.highrange- + parraydef(pfrom^.resulttype)^.lowrange+1; if l>255 then CGMessage(type_e_mismatch); { write the length } exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,l, - newreference(p^.location.reference)))); + newreference(pto^.location.reference)))); { copy to first char of string } - inc(p^.location.reference.offset); + inc(pto^.location.reference.offset); { generates the copy code } { and we need the source never } - concatcopy(p^.left^.location.reference,p^.location.reference,l,true,false); + concatcopy(pfrom^.location.reference,pto^.location.reference,l,true,false); { correct the string location } - dec(p^.location.reference.offset); + dec(pto^.location.reference.offset); end; - procedure second_char_to_string(p,hp : ptree;convtyp : tconverttype); + procedure second_char_to_string(pto,pfrom : ptree;convtyp : tconverttype); var pushed : tpushed; begin - clear_location(p^.location); - p^.location.loc:=LOC_MEM; - case pstringdef(p^.resulttype)^.string_typ of + clear_location(pto^.location); + pto^.location.loc:=LOC_MEM; + case pstringdef(pto^.resulttype)^.string_typ of st_shortstring : begin - gettempofsizereference(256,p^.location.reference); + gettempofsizereference(256,pto^.location.reference); { call loadstring with correct left and right } - p^.right:=p^.left; - p^.left:=p; - loadshortstring(p); - p^.left:=nil; { reset left tree, which is empty } - { p^.right is not disposed for typeconv !! PM } - disposetree(p^.right); - p^.right:=nil; + pto^.right:=pfrom; + pto^.left:=pto; + loadshortstring(pto); + pto^.left:=nil; { reset left tree, which is empty } + { pto^.right is not disposed for typeconv !! PM } + disposetree(pto^.right); + pto^.right:=nil; end; st_ansistring : begin - gettempofsizereference(4,p^.location.reference); - {temptoremove^.concat(new(ptemptodestroy,init(p^.location.reference,p^.resulttype)));} - exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L,0,newreference(p^.location.reference)))); + gettempofsizereference(4,pto^.location.reference); + {temptoremove^.concat(new(ptemptodestroy,init(pto^.location.reference,pto^.resulttype)));} + exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L,0,newreference(pto^.location.reference)))); pushusedregisters(pushed,$ff); - emit_pushw_loc(p^.left^.location); - emitpushreferenceaddr(exprasmlist,p^.location.reference); + emit_pushw_loc(pfrom^.location); + emitpushreferenceaddr(exprasmlist,pto^.location.reference); emitcall('FPC_CHAR_TO_ANSISTR',true); popusedregisters(pushed); maybe_loadesi; @@ -623,7 +712,7 @@ implementation end; - procedure second_int_real(p,hp : ptree;convtyp : tconverttype); + procedure second_int_to_real(pto,pfrom : ptree;convtyp : tconverttype); var r : preference; hregister : tregister; @@ -631,60 +720,60 @@ implementation { for u32bit a solution is to push $0 and to load a comp } { does this first, it destroys maybe EDI } hregister:=R_EDI; - if porddef(p^.left^.resulttype)^.typ=u32bit then + if porddef(pfrom^.resulttype)^.typ=u32bit then push_int(0); - if (p^.left^.location.loc=LOC_REGISTER) or - (p^.left^.location.loc=LOC_CREGISTER) then + if (pfrom^.location.loc=LOC_REGISTER) or + (pfrom^.location.loc=LOC_CREGISTER) then begin - case porddef(p^.left^.resulttype)^.typ of - s8bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_BL,p^.left^.location.register,R_EDI))); - u8bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,p^.left^.location.register,R_EDI))); - s16bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_WL,p^.left^.location.register,R_EDI))); - u16bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,p^.left^.location.register,R_EDI))); + case porddef(pfrom^.resulttype)^.typ of + s8bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_BL,pfrom^.location.register,R_EDI))); + u8bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,pfrom^.location.register,R_EDI))); + s16bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_WL,pfrom^.location.register,R_EDI))); + u16bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,pfrom^.location.register,R_EDI))); u32bit,s32bit: - hregister:=p^.left^.location.register + hregister:=pfrom^.location.register end; - ungetregister(p^.left^.location.register); + ungetregister(pfrom^.location.register); end else begin - r:=newreference(p^.left^.location.reference); - case porddef(p^.left^.resulttype)^.typ of + r:=newreference(pfrom^.location.reference); + case porddef(pfrom^.resulttype)^.typ of s8bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_BL,r,R_EDI))); u8bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,r,R_EDI))); s16bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_WL,r,R_EDI))); u16bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_WL,r,R_EDI))); u32bit,s32bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI))); end; - del_reference(p^.left^.location.reference); - ungetiftemp(p^.left^.location.reference); + del_reference(pfrom^.location.reference); + ungetiftemp(pfrom^.location.reference); end; exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,hregister))); r:=new_reference(R_ESP,0); - if porddef(p^.left^.resulttype)^.typ=u32bit then + if porddef(pfrom^.resulttype)^.typ=u32bit then exprasmlist^.concat(new(pai386,op_ref(A_FILD,S_IQ,r))) else exprasmlist^.concat(new(pai386,op_ref(A_FILD,S_IL,r))); { better than an add on all processors } - if porddef(p^.left^.resulttype)^.typ=u32bit then + if porddef(pfrom^.resulttype)^.typ=u32bit then exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,8,R_ESP))) else exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI))); - clear_location(p^.location); - p^.location.loc:=LOC_FPU; + clear_location(pto^.location); + pto^.location.loc:=LOC_FPU; end; - procedure second_real_fix(p,hp : ptree;convtyp : tconverttype); + procedure second_real_to_fix(pto,pfrom : ptree;convtyp : tconverttype); var rreg : tregister; ref : treference; begin { real must be on fpu stack } - if (p^.left^.location.loc<>LOC_FPU) then - exprasmlist^.concat(new(pai386,op_ref(A_FLD,S_FL,newreference(p^.left^.location.reference)))); + if (pfrom^.location.loc<>LOC_FPU) then + exprasmlist^.concat(new(pai386,op_ref(A_FLD,S_FL,newreference(pfrom^.location.reference)))); push_int($1f3f); push_int(65536); reset_reference(ref); @@ -709,41 +798,41 @@ implementation { better than an add on all processors } exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI))); - clear_location(p^.location); - p^.location.loc:=LOC_REGISTER; - p^.location.register:=rreg; + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + pto^.location.register:=rreg; end; - procedure second_float_float(p,hp : ptree;convtyp : tconverttype); + procedure second_real_to_real(pto,pfrom : ptree;convtyp : tconverttype); begin - case p^.left^.location.loc of + case pfrom^.location.loc of LOC_FPU : ; LOC_MEM, LOC_REFERENCE: begin - floatload(pfloatdef(p^.left^.resulttype)^.typ, - p^.left^.location.reference); + floatload(pfloatdef(pfrom^.resulttype)^.typ, + pfrom^.location.reference); { we have to free the reference } - del_reference(p^.left^.location.reference); + del_reference(pfrom^.location.reference); end; end; - clear_location(p^.location); - p^.location.loc:=LOC_FPU; + clear_location(pto^.location); + pto^.location.loc:=LOC_FPU; end; - procedure second_fix_real(p,hp : ptree;convtyp : tconverttype); + procedure second_fix_to_real(pto,pfrom : ptree;convtyp : tconverttype); var popeax,popebx,popecx,popedx : boolean; startreg : tregister; hl : plabel; r : treference; begin - if (p^.left^.location.loc=LOC_REGISTER) or - (p^.left^.location.loc=LOC_CREGISTER) then + if (pfrom^.location.loc=LOC_REGISTER) or + (pfrom^.location.loc=LOC_CREGISTER) then begin - startreg:=p^.left^.location.register; + startreg:=pfrom^.location.register; ungetregister(startreg); popeax:=(startreg<>R_EAX) and not (R_EAX in unused); if popeax then @@ -754,8 +843,8 @@ implementation else begin exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference( - p^.left^.location.reference),R_EAX))); - del_reference(p^.left^.location.reference); + pfrom^.location.reference),R_EAX))); + del_reference(pfrom^.location.reference); startreg:=R_NO; end; @@ -806,57 +895,57 @@ implementation if popeax then exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EAX))); - clear_location(p^.location); - p^.location.loc:=LOC_FPU; + clear_location(pto^.location); + pto^.location.loc:=LOC_FPU; end; - procedure second_int_fix(p,hp : ptree;convtyp : tconverttype); + procedure second_int_to_fix(pto,pfrom : ptree;convtyp : tconverttype); var hregister : tregister; begin - if (p^.left^.location.loc=LOC_REGISTER) then - hregister:=p^.left^.location.register - else if (p^.left^.location.loc=LOC_CREGISTER) then + if (pfrom^.location.loc=LOC_REGISTER) then + hregister:=pfrom^.location.register + else if (pfrom^.location.loc=LOC_CREGISTER) then hregister:=getregister32 else begin - del_reference(p^.left^.location.reference); + del_reference(pfrom^.location.reference); hregister:=getregister32; - case porddef(p^.left^.resulttype)^.typ of - s8bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_BL,newreference(p^.left^.location.reference), + case porddef(pfrom^.resulttype)^.typ of + s8bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_BL,newreference(pfrom^.location.reference), hregister))); - u8bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.left^.location.reference), + u8bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(pfrom^.location.reference), hregister))); - s16bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_WL,newreference(p^.left^.location.reference), + s16bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_WL,newreference(pfrom^.location.reference), hregister))); - u16bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.left^.location.reference), + u16bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_WL,newreference(pfrom^.location.reference), hregister))); - u32bit,s32bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), + u32bit,s32bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference), hregister))); {!!!! u32bit } end; end; exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,16,hregister))); - clear_location(p^.location); - p^.location.loc:=LOC_REGISTER; - p^.location.register:=hregister; + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + pto^.location.register:=hregister; end; - procedure second_proc_to_procvar(p,hp : ptree;convtyp : tconverttype); + procedure second_proc_to_procvar(pto,pfrom : ptree;convtyp : tconverttype); begin - clear_location(p^.location); - p^.location.loc:=LOC_REGISTER; - del_reference(hp^.location.reference); - p^.location.register:=getregister32; + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + pto^.location.register:=getregister32; + del_reference(pfrom^.location.reference); exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(hp^.location.reference),p^.location.register))); + newreference(pfrom^.location.reference),pto^.location.register))); end; - procedure second_bool_to_int(p,hp : ptree;convtyp : tconverttype); + procedure second_bool_to_int(pto,pfrom : ptree;convtyp : tconverttype); var oldtruelabel,oldfalselabel,hlabel : plabel; hregister : tregister; @@ -868,23 +957,23 @@ implementation oldfalselabel:=falselabel; getlabel(truelabel); getlabel(falselabel); - secondpass(hp); - clear_location(p^.location); - p^.location.loc:=LOC_REGISTER; - del_reference(hp^.location.reference); - case hp^.resulttype^.size of + secondpass(pfrom); + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + del_reference(pfrom^.location.reference); + case pfrom^.resulttype^.size of 1 : begin - case p^.resulttype^.size of + case pto^.resulttype^.size of 1 : opsize:=S_B; 2 : opsize:=S_BW; 4 : opsize:=S_BL; end; end; 2 : begin - case p^.resulttype^.size of + case pto^.resulttype^.size of 1 : begin - if hp^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then - hp^.location.register:=reg16toreg8(hp^.location.register); + if pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then + pfrom^.location.register:=reg16toreg8(pfrom^.location.register); opsize:=S_B; end; 2 : opsize:=S_W; @@ -892,15 +981,15 @@ implementation end; end; 4 : begin - case p^.resulttype^.size of + case pto^.resulttype^.size of 1 : begin - if hp^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then - hp^.location.register:=reg32toreg8(hp^.location.register); + if pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then + pfrom^.location.register:=reg32toreg8(pfrom^.location.register); opsize:=S_B; end; 2 : begin - if hp^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then - hp^.location.register:=reg32toreg16(hp^.location.register); + if pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then + pfrom^.location.register:=reg32toreg16(pfrom^.location.register); opsize:=S_W; end; 4 : opsize:=S_L; @@ -910,45 +999,45 @@ implementation if opsize in [S_B,S_W,S_L] then op:=A_MOV else - if is_signed(p^.resulttype) then + if is_signed(pto^.resulttype) then op:=A_MOVSX else op:=A_MOVZX; hregister:=getregister32; - case p^.resulttype^.size of + case pto^.resulttype^.size of 1 : begin - p^.location.register:=reg32toreg8(hregister); + pto^.location.register:=reg32toreg8(hregister); newsize:=S_B; end; 2 : begin - p^.location.register:=reg32toreg16(hregister); + pto^.location.register:=reg32toreg16(hregister); newsize:=S_W; end; 4 : begin - p^.location.register:=hregister; + pto^.location.register:=hregister; newsize:=S_L; end; else internalerror(10060); end; - case hp^.location.loc of + case pfrom^.location.loc of LOC_MEM, LOC_REFERENCE : exprasmlist^.concat(new(pai386,op_ref_reg(op,opsize, - newreference(hp^.location.reference),p^.location.register))); + newreference(pfrom^.location.reference),pto^.location.register))); LOC_REGISTER, LOC_CREGISTER : begin { remove things like movb %al,%al } - if hp^.location.register<>p^.location.register then + if pfrom^.location.register<>pto^.location.register then exprasmlist^.concat(new(pai386,op_reg_reg(op,opsize, - hp^.location.register,p^.location.register))); + pfrom^.location.register,pto^.location.register))); end; LOC_FLAGS : begin hregister:=reg32toreg8(hregister); - exprasmlist^.concat(new(pai386,op_reg(flag_2_set[hp^.location.resflags],S_B,hregister))); - case p^.resulttype^.size of - 2 : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BW,hregister,p^.location.register))); - 4 : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,hregister,p^.location.register))); + exprasmlist^.concat(new(pai386,op_reg(flag_2_set[pfrom^.location.resflags],S_B,hregister))); + case pto^.resulttype^.size of + 2 : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BW,hregister,pto^.location.register))); + 4 : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,hregister,pto^.location.register))); end; end; LOC_JUMP : begin @@ -970,39 +1059,39 @@ implementation end; - procedure second_int_to_bool(p,hp : ptree;convtyp : tconverttype); + procedure second_int_to_bool(pto,pfrom : ptree;convtyp : tconverttype); var hregister : tregister; begin - clear_location(p^.location); - p^.location.loc:=LOC_REGISTER; - del_reference(hp^.location.reference); - case hp^.location.loc of + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; + del_reference(pfrom^.location.reference); + case pfrom^.location.loc of LOC_MEM,LOC_REFERENCE : begin hregister:=getregister32; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(hp^.location.reference),hregister))); + newreference(pfrom^.location.reference),hregister))); end; LOC_REGISTER,LOC_CREGISTER : begin - hregister:=hp^.location.register; + hregister:=pfrom^.location.register; end; else internalerror(10062); end; exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_L,hregister,hregister))); hregister:=reg32toreg8(hregister); - exprasmlist^.concat(new(pai386,op_reg(flag_2_set[hp^.location.resflags],S_B,hregister))); - case p^.resulttype^.size of - 1 : p^.location.register:=hregister; + exprasmlist^.concat(new(pai386,op_reg(flag_2_set[pfrom^.location.resflags],S_B,hregister))); + case pto^.resulttype^.size of + 1 : pto^.location.register:=hregister; 2 : begin - p^.location.register:=reg8toreg16(hregister); - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BW,hregister,p^.location.register))); + pto^.location.register:=reg8toreg16(hregister); + exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BW,hregister,pto^.location.register))); end; 4 : begin - p^.location.register:=reg8toreg32(hregister); - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,hregister,p^.location.register))); + pto^.location.register:=reg8toreg32(hregister); + exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,hregister,pto^.location.register))); end; else internalerror(10064); @@ -1010,7 +1099,7 @@ implementation end; - procedure second_load_smallset(p,hp : ptree;convtyp : tconverttype); + procedure second_load_smallset(pto,pfrom : ptree;convtyp : tconverttype); var href : treference; pushedregs : tpushed; @@ -1018,115 +1107,114 @@ implementation href.symbol:=nil; pushusedregisters(pushedregs,$ff); gettempofsizereference(32,href); - emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); + emitpushreferenceaddr(exprasmlist,pfrom^.location.reference); emitpushreferenceaddr(exprasmlist,href); emitcall('FPC_SET_LOAD_SMALL',true); maybe_loadesi; popusedregisters(pushedregs); - clear_location(p^.location); - p^.location.loc:=LOC_MEM; - p^.location.reference:=href; + clear_location(pto^.location); + pto^.location.loc:=LOC_MEM; + pto^.location.reference:=href; end; - procedure second_ansistring_to_pchar(p,hp : ptree;convtyp : tconverttype); + procedure second_ansistring_to_pchar(pto,pfrom : ptree;convtyp : tconverttype); var l1,l2 : plabel; hr : preference; begin - clear_location(p^.location); - p^.location.loc:=LOC_REGISTER; + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; getlabel(l1); getlabel(l2); - case hp^.location.loc of + case pfrom^.location.loc of LOC_CREGISTER,LOC_REGISTER: exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,S_L,0, - hp^.location.register))); + pfrom^.location.register))); LOC_MEM,LOC_REFERENCE: begin exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_L,0, - newreference(hp^.location.reference)))); - del_reference(hp^.location.reference); - p^.location.register:=getregister32; + newreference(pfrom^.location.reference)))); + del_reference(pfrom^.location.reference); + pto^.location.register:=getregister32; end; end; emitl(A_JZ,l1); - if hp^.location.loc in [LOC_MEM,LOC_REFERENCE] then + if pfrom^.location.loc in [LOC_MEM,LOC_REFERENCE] then exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference( - hp^.location.reference), - p^.location.register))); + pfrom^.location.reference), + pto^.location.register))); emitl(A_JMP,l2); emitl(A_LABEL,l1); new(hr); reset_reference(hr^); hr^.symbol:=stringdup('FPC_EMPTYCHAR'); exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,hr, - p^.location.register))); + pto^.location.register))); emitl(A_LABEL,l2); end; - procedure second_pchar_to_string(p,hp : ptree;convtyp : tconverttype); + procedure second_pchar_to_string(pto,pfrom : ptree;convtyp : tconverttype); var pushed : tpushed; begin - case pstringdef(p^.resulttype)^.string_typ of + case pstringdef(pto^.resulttype)^.string_typ of st_shortstring: begin pushusedregisters(pushed,$ff); - stringdispose(p^.location.reference.symbol); - gettempofsizereference(p^.resulttype^.size,p^.location.reference); - case p^.left^.location.loc of + stringdispose(pto^.location.reference.symbol); + gettempofsizereference(pto^.resulttype^.size,pto^.location.reference); + case pfrom^.location.loc of LOC_REGISTER,LOC_CREGISTER: begin - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register))); - ungetregister32(p^.left^.location.register); + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,pfrom^.location.register))); + ungetregister32(pfrom^.location.register); end; LOC_REFERENCE,LOC_MEM: begin - emit_push_mem(p^.left^.location.reference); - del_reference(p^.left^.location.reference); + emit_push_mem(pfrom^.location.reference); + del_reference(pfrom^.location.reference); end; end; - emitpushreferenceaddr(exprasmlist,p^.location.reference); + emitpushreferenceaddr(exprasmlist,pto^.location.reference); emitcall('FPC_PCHAR_TO_SHORTSTR',true); maybe_loadesi; popusedregisters(pushed); end; st_ansistring: begin - stringdispose(p^.location.reference.symbol); - gettempofsizereference(p^.resulttype^.size,p^.location.reference); - case p^.left^.location.loc of + stringdispose(pto^.location.reference.symbol); + gettempofsizereference(pto^.resulttype^.size,pto^.location.reference); + case pfrom^.location.loc of LOC_REGISTER,LOC_CREGISTER: begin - ungetregister32(p^.left^.location.register); + ungetregister32(pfrom^.location.register); pushusedregisters(pushed,$ff); - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register))); + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,pfrom^.location.register))); end; LOC_REFERENCE,LOC_MEM: begin - del_reference(p^.left^.location.reference); + del_reference(pfrom^.location.reference); pushusedregisters(pushed,$ff); - emit_push_mem(p^.left^.location.reference); + emit_push_mem(pfrom^.location.reference); end; end; - emitpushreferenceaddr(exprasmlist,p^.location.reference); + emitpushreferenceaddr(exprasmlist,pto^.location.reference); emitcall('FPC_PCHAR_TO_ANSISTR',true); maybe_loadesi; popusedregisters(pushed); end; else begin - clear_location(p^.location); - p^.location.loc:=LOC_REGISTER; + clear_location(pto^.location); + pto^.location.loc:=LOC_REGISTER; internalerror(12121); end; end; end; - - procedure second_nothing(p,hp : ptree;convtyp : tconverttype); + procedure second_nothing(pto,pfrom : ptree;convtyp : tconverttype); begin end; @@ -1136,15 +1224,40 @@ implementation ****************************************************************************} procedure secondtypeconv(var p : ptree); - const - secondconvert : array[tconverttype] of - tsecondconvproc = (second_nothing,second_nothing, + secondconvert : array[tconverttype] of tsecondconvproc = ( +{$ifdef NEWCNV} + second_nothing, {equal} + second_nothing, {not_possible} + second_string_to_string, + second_char_to_string, + second_pchar_to_string, + second_nothing, {cchar_to_pchar} + second_cstring_to_pchar, + second_ansistring_to_pchar, + second_string_to_chararray, + second_chararray_to_string, + second_array_to_pointer, + second_pointer_to_array, + second_int_to_int, + second_bool_to_int, + second_int_to_bool, + second_real_to_real, + second_int_to_real, + second_int_to_fix, + second_real_to_fix, + second_fix_to_real, + second_proc_to_procvar, + second_nothing, {arrayconstructor_to_set} + second_load_smallset + ); +{$else} + second_nothing,second_nothing, second_bigger,second_only_rangecheck, second_bigger,second_bigger,second_bigger, second_smaller,second_smaller, - second_smaller,second_string_string, - second_cstring_charpointer,second_string_chararray, + second_smaller,second_string_to_string, + second_cstring_to_pchar,second_string_to_chararray, second_array_to_pointer,second_pointer_to_array, second_char_to_string,second_bigger, second_bigger,second_bigger, @@ -1157,8 +1270,8 @@ implementation second_smaller,second_smaller, second_smaller,second_smaller, second_bool_to_int,second_int_to_bool, - second_int_real,second_real_fix, - second_fix_real,second_int_fix,second_float_float, + second_int_to_real,second_real_to_fix, + second_fix_to_real,second_int_to_fix,second_real_to_real, second_chararray_to_string, second_proc_to_procvar, { is constant char to pchar, is done by firstpass } @@ -1167,12 +1280,12 @@ implementation second_ansistring_to_pchar, second_pchar_to_string, second_nothing); - +{$endif} begin { this isn't good coding, I think tc_bool_2_int, shouldn't be } { type conversion (FK) } - { this is necessary, because second_bool_byte, have to change } + { this is necessary, because second_bool_2_int, have to change } { true- and false label before calling secondpass } if p^.convtyp<>tc_bool_2_int then begin @@ -1181,10 +1294,8 @@ implementation if codegenerror then exit; end; - - if not(p^.convtyp in [tc_equal,tc_not_possible]) then - {the second argument only is for maybe_range_checking !} - secondconvert[p^.convtyp](p,p^.left,p^.convtyp) + {the second argument only is for maybe_range_checking !} + secondconvert[p^.convtyp](p,p^.left,p^.convtyp) end; @@ -1297,7 +1408,11 @@ implementation end. { $Log$ - Revision 1.34 1998-11-18 15:44:08 peter + Revision 1.35 1998-11-26 13:10:39 peter + * new int - int conversion -dNEWCNV + * some function renamings + + Revision 1.34 1998/11/18 15:44:08 peter * VALUEPARA for tp7 compatible value parameters Revision 1.33 1998/11/17 00:36:39 peter diff --git a/compiler/cg386inl.pas b/compiler/cg386inl.pas index ff793b6105..802c8483f2 100644 --- a/compiler/cg386inl.pas +++ b/compiler/cg386inl.pas @@ -739,7 +739,7 @@ implementation exprasmlist^.concat(new(pai386,op_reg(asmop,opsize, p^.location.register))); emitoverflowcheck(p); - emitrangecheck(p); + emitrangecheck(p,p^.resulttype); end; in_dec_x, in_inc_x : @@ -843,7 +843,7 @@ implementation ungetregister32(hregister); end; emitoverflowcheck(p^.left^.left); - emitrangecheck(p^.left^.left); + emitrangecheck(p^.left^.left,p^.left^.left^.resulttype); end; in_assigned_x : begin @@ -970,7 +970,11 @@ implementation end. { $Log$ - Revision 1.18 1998-11-24 17:04:27 peter + Revision 1.19 1998-11-26 13:10:40 peter + * new int - int conversion -dNEWCNV + * some function renamings + + Revision 1.18 1998/11/24 17:04:27 peter * fixed length(char) when char is a variable Revision 1.17 1998/11/05 12:02:33 peter diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas index fe74f5eb7e..9b98ea34aa 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -64,11 +64,26 @@ implementation function isconvertable(def_from,def_to : pdef; var doconv : tconverttype;fromtreetype : ttreetyp; explicit : boolean) : boolean; - const +{$ifdef NEWCNV} { Tbasetype: uauto,uvoid,uchar, u8bit,u16bit,u32bit, s8bit,s16bit,s32, bool8bit,bool16bit,boot32bit } + type + tbasedef=(bvoid,bchar,bint,bbool); + const + basedeftbl:array[tbasetype] of tbasedef = + (bvoid,bvoid,bchar, + bint,bint,bint, + bint,bint,bint, + bbool,bbool,bbool); + basedefconverts : array[tbasedef,tbasedef] of tconverttype = + ((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible), + (tc_not_possible,tc_equal,tc_not_possible,tc_not_possible), + (tc_not_possible,tc_not_possible,tc_int_2_int,tc_int_2_bool), + (tc_not_possible,tc_not_possible,tc_bool_2_int,tc_int_2_bool)); +{$else} + const basedefconverts : array[tbasetype,tbasetype] of tconverttype = {uauto} ((tc_not_possible,tc_not_possible,tc_not_possible, @@ -130,6 +145,7 @@ implementation tc_bool_2_int,tc_bool_2_int,tc_bool_2_int, tc_bool_2_int,tc_bool_2_int,tc_bool_2_int, tc_int_2_bool,tc_int_2_bool,tc_only_rangechecks32bit)); +{$endif} var b : boolean; @@ -148,30 +164,49 @@ implementation case def_to^.deftype of orddef : begin - if (def_from^.deftype=orddef) then - begin - doconv:=basedefconverts[porddef(def_from)^.typ,porddef(def_to)^.typ]; - b:=true; - if (doconv=tc_not_possible) or - ((doconv=tc_int_2_bool) and - (not explicit) and - (not is_boolean(def_from))) then - b:=false; - end; + case def_from^.deftype of + orddef : + begin +{$ifdef NEWCNV} + doconv:=basedefconverts[basedeftbl[porddef(def_from)^.typ],basedeftbl[porddef(def_to)^.typ]]; + b:=true; + if (doconv=tc_not_possible) or + ((doconv=tc_int_2_bool) and + (not explicit) and + (not is_boolean(def_from))) then + b:=false; +{$else} + doconv:=basedefconverts[porddef(def_from)^.typ,porddef(def_to)^.typ]; + b:=true; + if (doconv=tc_not_possible) or + ((doconv=tc_int_2_bool) and + (not explicit) and + (not is_boolean(def_from))) then + b:=false; +{$endif} + end; +{$ifdef NEWCNV} + enumdef : + begin + doconv:=tc_int_2_int; + b:=true; + end; +{$endif} + end; end; stringdef : begin case def_from^.deftype of stringdef : begin - doconv:=tc_string_to_string; + doconv:=tc_string_2_string; b:=true; end; orddef : begin { char to string} if is_char(def_from) then begin - doconv:=tc_char_to_string; + doconv:=tc_char_2_string; b:=true; end; end; @@ -261,7 +296,7 @@ implementation if (parraydef(def_to)^.lowrange=0) and is_equal(ppointerdef(def_from)^.definition,parraydef(def_to)^.definition) then begin - doconv:=tc_pointer_to_array; + doconv:=tc_pointer_2_array; b:=true; end; end; @@ -269,7 +304,7 @@ implementation { array of char to string } if is_equal(parraydef(def_to)^.definition,cchardef) then begin - doconv:=tc_string_chararray; + doconv:=tc_string_2_chararray; b:=true; end; end; @@ -285,16 +320,16 @@ implementation if (fromtreetype=stringconstn) and is_pchar(def_to) then begin - doconv:=tc_cstring_charpointer; + doconv:=tc_cstring_2_pchar; b:=true; end; end; orddef : begin { char constant to zero terminated string constant } if (fromtreetype=ordconstn) and is_equal(def_from,cchardef) and - is_pchar(def_to) then + is_pchar(def_to) then begin - doconv:=tc_cchar_charpointer; + doconv:=tc_cchar_2_pchar; b:=true; end; end; @@ -303,7 +338,7 @@ implementation if (parraydef(def_from)^.lowrange=0) and is_equal(parraydef(def_from)^.definition,ppointerdef(def_to)^.definition) then begin - doconv:=tc_array_to_pointer; + doconv:=tc_array_2_pointer; b:=true; end; end; @@ -370,7 +405,7 @@ implementation if (def_from^.deftype=procdef) then begin def_from^.deftype:=procvardef; - doconv:=tc_proc2procvar; + doconv:=tc_proc_2_procvar; b:=is_equal(def_from,def_to); def_from^.deftype:=procdef; end @@ -675,7 +710,11 @@ implementation end. { $Log$ - Revision 1.8 1998-11-17 00:36:42 peter + Revision 1.9 1998-11-26 13:10:42 peter + * new int - int conversion -dNEWCNV + * some function renamings + + Revision 1.8 1998/11/17 00:36:42 peter * more ansistring fixes Revision 1.7 1998/10/14 13:33:24 peter diff --git a/compiler/tccnv.pas b/compiler/tccnv.pas index 7e2c97d117..e6796e1bf4 100644 --- a/compiler/tccnv.pas +++ b/compiler/tccnv.pas @@ -234,30 +234,43 @@ implementation type tfirstconvproc = procedure(var p : ptree); +{$ifdef NEWCNV} + procedure first_int_to_int(var p : ptree); + begin + if (p^.registers32=0) and + (p^.left^.location.loc<>LOC_REGISTER) and + (p^.resulttype^.size>p^.left^.resulttype^.size) then + begin + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + end; + end; + +{$else} procedure first_bigger_smaller(var p : ptree); begin if (p^.left^.location.loc<>LOC_REGISTER) and (p^.registers32=0) then p^.registers32:=1; p^.location.loc:=LOC_REGISTER; end; +{$endif} - - procedure first_cstring_charpointer(var p : ptree); + procedure first_cstring_to_pchar(var p : ptree); begin p^.registers32:=1; p^.location.loc:=LOC_REGISTER; end; - procedure first_string_chararray(var p : ptree); + procedure first_string_to_chararray(var p : ptree); begin p^.registers32:=1; p^.location.loc:=LOC_REGISTER; end; - procedure first_string_string(var p : ptree); + procedure first_string_to_string(var p : ptree); begin if pstringdef(p^.resulttype)^.string_typ<> pstringdef(p^.left^.resulttype)^.string_typ then @@ -309,7 +322,7 @@ implementation end; - procedure first_int_real(var p : ptree); + procedure first_int_to_real(var p : ptree); var t : ptree; begin @@ -338,7 +351,7 @@ implementation end; - procedure first_int_fix(var p : ptree); + procedure first_int_to_fix(var p : ptree); begin if p^.left^.treetype=ordconstn then begin @@ -358,7 +371,7 @@ implementation end; - procedure first_real_fix(var p : ptree); + procedure first_real_to_fix(var p : ptree); begin if p^.left^.treetype=realconstn then begin @@ -381,7 +394,7 @@ implementation end; - procedure first_fix_real(var p : ptree); + procedure first_fix_to_real(var p : ptree); begin if p^.left^.treetype=fixconstn then begin @@ -401,7 +414,7 @@ implementation end; - procedure first_real_real(var p : ptree); + procedure first_real_to_real(var p : ptree); begin if p^.registersfpu<1 then p^.registersfpu:=1; @@ -417,7 +430,7 @@ implementation end; - procedure first_chararray_string(var p : ptree); + procedure first_chararray_to_string(var p : ptree); begin { the only important information is the location of the } { result } @@ -426,7 +439,7 @@ implementation end; - procedure first_cchar_charpointer(var p : ptree); + procedure first_cchar_to_pchar(var p : ptree); begin p^.left:=gentypeconvnode(p^.left,cshortstringdef); { convert constant char to constant string } @@ -436,13 +449,15 @@ implementation end; +{$ifndef NEWCNV} procedure first_locmem(var p : ptree); begin p^.location.loc:=LOC_MEM; end; +{$endif} - procedure first_bool_int(var p : ptree); + procedure first_bool_to_int(var p : ptree); begin p^.location.loc:=LOC_REGISTER; { Florian I think this is overestimated @@ -456,7 +471,7 @@ implementation end; - procedure first_int_bool(var p : ptree); + procedure first_int_to_bool(var p : ptree); begin p^.location.loc:=LOC_REGISTER; { Florian I think this is overestimated @@ -500,6 +515,7 @@ implementation p^.location.loc:=LOC_MEM; end; + procedure first_ansistring_to_pchar(var p : ptree); begin p^.location.loc:=LOC_REGISTER; @@ -529,13 +545,39 @@ implementation aprocdef : pprocdef; proctype : tdeftype; const - firstconvert : array[tconverttype] of - tfirstconvproc = (first_nothing,first_nothing, + firstconvert : array[tconverttype] of tfirstconvproc = ( +{$ifdef NEWCNV} + first_nothing, {equal} + first_nothing, {not_possible} + first_string_to_string, + first_char_to_string, + first_pchar_to_string, + first_cchar_to_pchar, + first_cstring_to_pchar, + first_ansistring_to_pchar, + first_string_to_chararray, + first_chararray_to_string, + first_array_to_pointer, + first_pointer_to_array, + first_int_to_int, + first_bool_to_int, + first_int_to_bool, + first_real_to_real, + first_int_to_real, + first_int_to_fix, + first_real_to_fix, + first_fix_to_real, + first_proc_to_procvar, + first_arrayconstructor_to_set, + first_load_smallset + ); +{$else} + first_nothing,first_nothing, first_bigger_smaller,first_nothing,first_bigger_smaller, first_bigger_smaller,first_bigger_smaller, first_bigger_smaller,first_bigger_smaller, - first_bigger_smaller,first_string_string, - first_cstring_charpointer,first_string_chararray, + first_bigger_smaller,first_string_to_string, + first_cstring_to_pchar,first_string_to_chararray, first_array_to_pointer,first_pointer_to_array, first_char_to_string,first_bigger_smaller, first_bigger_smaller,first_bigger_smaller, @@ -547,16 +589,16 @@ implementation first_bigger_smaller,first_bigger_smaller, first_bigger_smaller,first_bigger_smaller, first_bigger_smaller,first_bigger_smaller, - first_bool_int,first_int_bool, - first_int_real,first_real_fix, - first_fix_real,first_int_fix,first_real_real, + first_bool_to_int,first_int_to_bool, + first_int_to_real,first_real_to_fix, + first_fix_to_real,first_int_to_fix,first_real_to_real, first_locmem,first_proc_to_procvar, - first_cchar_charpointer, + first_cchar_to_pchar, first_load_smallset, first_ansistring_to_pchar, first_pchar_to_string, first_arrayconstructor_to_set); - +{$endif} begin aprocdef:=nil; { if explicite type cast, then run firstpass } @@ -689,7 +731,7 @@ implementation aprocdef:=pprocsym(p^.left^.symtableentry)^.definition; end; - p^.convtyp:=tc_proc2procvar; + p^.convtyp:=tc_proc_2_procvar; { Now check if the procedure we are going to assign to the procvar, is compatible with the procvar's type. Did the original procvar support do such a check? @@ -913,7 +955,11 @@ implementation end. { $Log$ - Revision 1.8 1998-11-05 12:03:03 peter + Revision 1.9 1998-11-26 13:10:43 peter + * new int - int conversion -dNEWCNV + * some function renamings + + Revision 1.8 1998/11/05 12:03:03 peter * released useansistring * removed -Sv, its now available in fpc modes diff --git a/compiler/tree.pas b/compiler/tree.pas index 2aab4a2eb6..4f8ebd8b17 100644 --- a/compiler/tree.pas +++ b/compiler/tree.pas @@ -45,96 +45,125 @@ unit tree; pconstset = ^tconstset; tconstset = array[0..31] of byte; - ttreetyp = (addn, {Represents the + operator.} - muln, {Represents the * operator.} - subn, {Represents the - operator.} - divn, {Represents the div operator.} - symdifn, {Represents the >< operator.} - modn, {Represents the mod operator.} - assignn, {Represents an assignment.} - loadn, {Represents the use of a variabele.} - rangen, {Represents a range (i.e. 0..9).} - ltn, {Represents the < operator.} - lten, {Represents the <= operator.} - gtn, {Represents the > operator.} - gten, {Represents the >= operator.} - equaln, {Represents the = operator.} - unequaln, {Represents the <> operator.} - inn, {Represents the in operator.} - orn, {Represents the or operator.} - xorn, {Represents the xor operator.} - shrn, {Represents the shr operator.} - shln, {Represents the shl operator.} - slashn, {Represents the / operator.} - andn, {Represents the and operator.} - subscriptn, {??? Field in a record/object?} - derefn, {Dereferences a pointer.} - addrn, {Represents the @ operator.} - doubleaddrn, {Represents the @@ operator.} - ordconstn, {Represents an ordinal value.} - typeconvn, {Represents type-conversion/typecast.} - calln, {Represents a call node.} - callparan, {Represents a parameter.} - realconstn, {Represents a real value.} - fixconstn, {Represents a fixed value.} - umminusn, {Represents a sign change (i.e. -2).} - asmn, {Represents an assembler node } - vecn, {Represents array indexing.} - stringconstn, {Represents a string constant.} - funcretn, {Represents the function result var.} - selfn, {Represents the self parameter.} - notn, {Represents the not operator.} - inlinen, {Internal procedures (i.e. writeln).} - niln, {Represents the nil pointer.} - errorn, {This part of the tree could not be - parsed because of a compiler error.} - typen, {A type name. Used for i.e. typeof(obj).} - hnewn, {The new operation, constructor call.} - hdisposen, {The dispose operation with destructor call.} - newn, {The new operation, constructor call.} - simpledisposen, {The dispose operation.} - setelementn, {A set element(s) (i.e. [a,b] and also [a..b]).} - setconstn, {A set constant (i.e. [1,2]).} - blockn, {A block of statements.} - statementn, {One statement in a block of nodes.} - loopn, { used in genloopnode, must be converted } - ifn, {An if statement.} - breakn, {A break statement.} - continuen, {A continue statement.} - repeatn, {A repeat until block.} - whilen, {A while do statement.} - forn, {A for loop.} - exitn, {An exit statement.} - withn, {A with statement.} - casen, {A case statement.} - labeln, {A label.} - goton, {A goto statement.} - simplenewn, {The new operation.} - tryexceptn, {A try except block.} - raisen, {A raise statement.} - switchesn, {??? Currently unused...} - tryfinallyn, {A try finally statement.} - onn, { for an on statement in exception code } - isn, {Represents the is operator.} - asn, {Represents the as typecast.} - caretn, {Represents the ^ operator.} - failn, {Represents the fail statement.} - starstarn, {Represents the ** operator exponentiation } - procinlinen, {Procedures that can be inlined } - arrayconstructn, {Construction node for [...] parsing} - arrayconstructrangen, {Range element to allow sets in array construction tree} - { added for optimizations where we cannot suppress } - nothingn, - loadvmtn); {???.} + ttreetyp = ( + addn, {Represents the + operator.} + muln, {Represents the * operator.} + subn, {Represents the - operator.} + divn, {Represents the div operator.} + symdifn, {Represents the >< operator.} + modn, {Represents the mod operator.} + assignn, {Represents an assignment.} + loadn, {Represents the use of a variabele.} + rangen, {Represents a range (i.e. 0..9).} + ltn, {Represents the < operator.} + lten, {Represents the <= operator.} + gtn, {Represents the > operator.} + gten, {Represents the >= operator.} + equaln, {Represents the = operator.} + unequaln, {Represents the <> operator.} + inn, {Represents the in operator.} + orn, {Represents the or operator.} + xorn, {Represents the xor operator.} + shrn, {Represents the shr operator.} + shln, {Represents the shl operator.} + slashn, {Represents the / operator.} + andn, {Represents the and operator.} + subscriptn, {??? Field in a record/object?} + derefn, {Dereferences a pointer.} + addrn, {Represents the @ operator.} + doubleaddrn, {Represents the @@ operator.} + ordconstn, {Represents an ordinal value.} + typeconvn, {Represents type-conversion/typecast.} + calln, {Represents a call node.} + callparan, {Represents a parameter.} + realconstn, {Represents a real value.} + fixconstn, {Represents a fixed value.} + umminusn, {Represents a sign change (i.e. -2).} + asmn, {Represents an assembler node } + vecn, {Represents array indexing.} + stringconstn, {Represents a string constant.} + funcretn, {Represents the function result var.} + selfn, {Represents the self parameter.} + notn, {Represents the not operator.} + inlinen, {Internal procedures (i.e. writeln).} + niln, {Represents the nil pointer.} + errorn, {This part of the tree could not be + parsed because of a compiler error.} + typen, {A type name. Used for i.e. typeof(obj).} + hnewn, {The new operation, constructor call.} + hdisposen, {The dispose operation with destructor call.} + newn, {The new operation, constructor call.} + simpledisposen, {The dispose operation.} + setelementn, {A set element(s) (i.e. [a,b] and also [a..b]).} + setconstn, {A set constant (i.e. [1,2]).} + blockn, {A block of statements.} + statementn, {One statement in a block of nodes.} + loopn, { used in genloopnode, must be converted } + ifn, {An if statement.} + breakn, {A break statement.} + continuen, {A continue statement.} + repeatn, {A repeat until block.} + whilen, {A while do statement.} + forn, {A for loop.} + exitn, {An exit statement.} + withn, {A with statement.} + casen, {A case statement.} + labeln, {A label.} + goton, {A goto statement.} + simplenewn, {The new operation.} + tryexceptn, {A try except block.} + raisen, {A raise statement.} + switchesn, {??? Currently unused...} + tryfinallyn, {A try finally statement.} + onn, { for an on statement in exception code } + isn, {Represents the is operator.} + asn, {Represents the as typecast.} + caretn, {Represents the ^ operator.} + failn, {Represents the fail statement.} + starstarn, {Represents the ** operator exponentiation } + procinlinen, {Procedures that can be inlined } + arrayconstructn, {Construction node for [...] parsing} + arrayconstructrangen, {Range element to allow sets in array construction tree} + { added for optimizations where we cannot suppress } + nothingn, + loadvmtn + ); +{$ifdef NEWCNV} + tconverttype = ( + tc_equal, + tc_not_possible, + tc_string_2_string, + tc_char_2_string, + tc_pchar_2_string, + tc_cchar_2_pchar, + tc_cstring_2_pchar, + tc_ansistring_2_pchar, + tc_string_2_chararray, + tc_chararray_2_string, + tc_array_2_pointer, + tc_pointer_2_array, + tc_int_2_int, + tc_bool_2_int, + tc_int_2_bool, + tc_real_2_real, + tc_int_2_real, + tc_int_2_fix, + tc_real_2_fix, + tc_fix_2_real, + tc_proc_2_procvar, + tc_arrayconstructor_2_set, + tc_load_smallset + ); +{$else} tconverttype = (tc_equal,tc_not_possible,tc_u8bit_2_s32bit, tc_only_rangechecks32bit,tc_s8bit_2_s32bit, tc_u16bit_2_s32bit,tc_s16bit_2_s32bit, tc_s32bit_2_s16bit,tc_s32bit_2_u8bit, - tc_s32bit_2_u16bit,tc_string_to_string, - tc_cstring_charpointer,tc_string_chararray, - tc_array_to_pointer,tc_pointer_to_array, - tc_char_to_string,tc_u8bit_2_s16bit, + tc_s32bit_2_u16bit,tc_string_2_string, + tc_cstring_2_pchar,tc_string_2_chararray, + tc_array_2_pointer,tc_pointer_2_array, + tc_char_2_string,tc_u8bit_2_s16bit, tc_u8bit_2_u16bit,tc_s8bit_2_s16bit, tc_s16bit_2_s8bit,tc_s16bit_2_u8bit, tc_u16bit_2_s8bit,tc_u16bit_2_u8bit, @@ -148,9 +177,10 @@ unit tree; tc_int_2_real,tc_real_2_fix, tc_fix_2_real,tc_int_2_fix,tc_real_2_real, tc_chararray_2_string, - tc_proc2procvar,tc_cchar_charpointer,tc_load_smallset, + tc_proc_2_procvar,tc_cchar_2_pchar,tc_load_smallset, tc_ansistring_2_pchar,tc_pchar_2_string, tc_arrayconstructor_2_set); +{$endif} { allows to determine which elementes are to be replaced } tdisposetyp = (dt_nothing,dt_leftright,dt_left, @@ -1622,7 +1652,11 @@ unit tree; end. { $Log$ - Revision 1.53 1998-11-24 12:52:42 peter + Revision 1.54 1998-11-26 13:10:44 peter + * new int - int conversion -dNEWCNV + * some function renamings + + Revision 1.53 1998/11/24 12:52:42 peter * sets are not written twice anymore * optimize for emptyset+single element which uses a new routine from set.inc FPC_SET_CREATE_ELEMENT