From 1e6d667c3bf2c5ad5e9c6cb0d8928c7079cb1e9f Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Tue, 16 Mar 1999 17:52:52 +0000 Subject: [PATCH] * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test) * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck") * in cgai386: also small fixes to emitrangecheck --- compiler/cg386inl.pas | 305 ++++++++++++++++++++++++++++++++++++++++-- compiler/pexpr.pas | 30 ++++- compiler/psystem.pas | 10 +- compiler/tcinl.pas | 77 ++++++++++- 4 files changed, 410 insertions(+), 12 deletions(-) diff --git a/compiler/cg386inl.pas b/compiler/cg386inl.pas index c160c0a147..44396ee38f 100644 --- a/compiler/cg386inl.pas +++ b/compiler/cg386inl.pas @@ -338,25 +338,91 @@ implementation emitcall('FPC_WRITE_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true); end; orddef : begin + {in the range checking code, hp^.left is stil the current parameter, since + hp only gets modified when doread is false (JM)} case porddef(pararesult)^.typ of u8bit : if doread then - emitcall('FPC_READ_TEXT_BYTE',true); +{$IfDef ReadRangeCheck} + Begin +{$EndIf ReadRangeCheck} + emitcall('FPC_READ_TEXT_BYTE',true); +{$IfDef ReadRangeCheck} + If (porddef(pararesult)^.low <> 0) or + (porddef(pararesult)^.high <> 255) Then + emitrangecheck(hp^.left,pararesult); + End; +{$EndIf ReadRangeCheck} + s8bit : if doread then - emitcall('FPC_READ_TEXT_SHORTINT',true); +{$IfDef ReadRangeCheck} + Begin +{$EndIf ReadRangeCheck} + emitcall('FPC_READ_TEXT_SHORTINT',true); +{$IfDef ReadRangeCheck} + If (porddef(pararesult)^.low <> -128) or + (porddef(pararesult)^.high <> 127) Then + emitrangecheck(hp^.left,pararesult); + End; +{$EndIf ReadRangeCheck} u16bit : if doread then - emitcall('FPC_READ_TEXT_WORD',true); +{$IfDef ReadRangeCheck} + Begin +{$EndIf ReadRangeCheck} + emitcall('FPC_READ_TEXT_WORD',true); +{$IfDef ReadRangeCheck} + If (porddef(pararesult)^.low <> 0) or + (porddef(pararesult)^.high <> 65535) Then + emitrangecheck(hp^.left,pararesult); + End; +{$EndIf ReadRangeCheck} s16bit : if doread then - emitcall('FPC_READ_TEXT_INTEGER',true); +{$IfDef ReadRangeCheck} + Begin +{$EndIf ReadRangeCheck} + emitcall('FPC_READ_TEXT_INTEGER',true); +{$IfDef ReadRangeCheck} + If (porddef(pararesult)^.low <> -32768) or + (porddef(pararesult)^.high <> 32767) Then + emitrangecheck(hp^.left,pararesult); + End; +{$EndIf ReadRangeCheck} s32bit : if doread then - emitcall('FPC_READ_TEXT_LONGINT',true) +{$IfDef ReadRangeCheck} + Begin +{$EndIf ReadRangeCheck} + emitcall('FPC_READ_TEXT_LONGINT',true) +{$IfDef ReadRangeCheck} + ;If (porddef(pararesult)^.low <> $80000000) or + (porddef(pararesult)^.high <> $7fffffff) Then + emitrangecheck(hp^.left,pararesult); + End +{$EndIf ReadRangeCheck} else emitcall('FPC_WRITE_TEXT_LONGINT',true); u32bit : if doread then - emitcall('FPC_READ_TEXT_CARDINAL',true) +{$IfDef ReadRangeCheck} + Begin +{$EndIf ReadRangeCheck} + emitcall('FPC_READ_TEXT_CARDINAL',true) +{$IfDef ReadRangeCheck} + ;If (porddef(pararesult)^.low <> $0) or + (porddef(pararesult)^.high <> $ffffffff) Then + emitrangecheck(hp^.left,pararesult); + End +{$EndIf ReadRangeCheck} else emitcall('FPC_WRITE_TEXT_CARDINAL',true); uchar : if doread then - emitcall('FPC_READ_TEXT_CHAR',true) +{$IfDef ReadRangeCheck} + Begin +{$EndIf ReadRangeCheck} + emitcall('FPC_READ_TEXT_CHAR',true) +{$IfDef ReadRangeCheck} + ;If (porddef(pararesult)^.low <> 0) or + (porddef(pararesult)^.high <> 255) Then + emitrangecheck(hp^.left,pararesult); + End +{$EndIf ReadRangeCheck} else emitcall('FPC_WRITE_TEXT_CHAR',true); s64bitint: @@ -535,7 +601,7 @@ implementation exit; if is_real then - emitcall(procedureprefix++float_name[pfloatdef(hp^.resulttype)^.typ],true) + emitcall(procedureprefix+float_name[pfloatdef(hp^.resulttype)^.typ],true) else case porddef(hp^.resulttype)^.typ of u32bit: @@ -553,6 +619,216 @@ implementation popusedregisters(pushed); end; +{$IfDef ValIntern} + + Procedure Handle_Val; + + var + hp,node, code_para, dest_para : ptree; + hreg: TRegister; + hdef: POrdDef; + pushed2: TPushed; + procedureprefix : string; + hr: TReference; + dummycoll : tdefcoll; + has_code, has_32bit_code, oldregisterdef: boolean; + + begin + {save the register variables} + pushusedregisters(pushed,$ff); + node:=p^.left; + hp:=node; + node:=node^.right; + hp^.right:=nil; + has_32bit_code := false; + {if we have 3 parameters, we have a code parameter} + has_code := Assigned(node^.right); + reset_reference(hr); + hreg := R_NO; + + {the function result will be in EAX, so we need to reserve it so + that secondpass(dest_para^.left) and secondpass(code_para^.left) + won't use it} + hreg := getexplicitregister32(R_EAX); + {if EAX is already in use, it's a register variable (ok, we've saved + those with pushusedregisters). Since we don't need another + register besides EAX, release it} + If hreg <> R_EAX Then ungetregister32(hreg); + + If has_code then + Begin + {code is an orddef, that's checked in tcinl} + If (porddef(hp^.left^.resulttype)^.typ in [u32bit,s32bit]) Then + Begin + has_32bit_code := true; + code_para := hp; + hp:=node; + node:=node^.right; + hp^.right:=nil; + End + Else + Begin + secondpass(hp^.left); + code_para := hp; + hp := node; + node:=node^.right; + hp^.right:=nil; + End; + End; + {hp = destination now, save for later use} + dest_para := hp; + secondpass(dest_para^.left); + + {unget EAX (if we got it before), since otherwise pushusedregisters + will push it on the stack. No more registers are allocated before + the function call that will also have to be accessed afterwards, + so if EAX is allocated now before the function call, it doesn't + matter.} + If (hreg = R_EAX) then Ungetregister32(R_EAX); + + {(if necessary) save the address loading of code_para and dest_para} + + pushusedregisters(pushed2,$ff); + + {now that we've already pushed the results from + secondpass(code_para^.left) and secondpass(dest_para^.left) on the + stack, we can put the real parameters on the stack} + + If has_32bit_code Then + Begin + dummycoll.paratyp:=vs_var; + dummycoll.data:=code_para^.resulttype; + secondcallparan(code_para,@dummycoll,false,false,0); + if codegenerror then + exit; + Disposetree(code_para); + End + Else + Begin + {only 32bit code parameter is supported, so fake one} + GetTempOfSizeReference(4,hr); + emitpushreferenceaddr(exprasmlist,hr); + End; + + Case dest_para^.resulttype^.deftype of + floatdef: procedureprefix := 'FPC_VAL_REAL_'; + orddef: + Case PordDef(dest_para^.resulttype)^.typ of + u8bit,u16bit,u32bit{,u64bit}: procedureprefix := 'FPC_VAL_UINT_'; + s8bit,s16bit,s32bit{,s64bitint}: procedureprefix := 'FPC_VAL_SINT_'; + End; + End; + + {node = first parameter = string} + dummycoll.paratyp:=vs_const; + dummycoll.data:=node^.resulttype; + secondcallparan(node,@dummycoll,false,false,0); + if codegenerror then + exit; + + {if we are converting to a signed number, we have to include the + size of the destination, so the Val function can extend the sign + of the result to allow proper range checking} + If (dest_para^.resulttype^.deftype = orddef) Then + Case PordDef(dest_para^.resulttype)^.typ of + s8bit: exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_W,1))); + s16bit: exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_W,2))); + s32bit: exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_W,4))); + End; + + case pstringdef(node^.resulttype)^.string_typ of + st_widestring: + emitcall(procedureprefix+'STRWIDE',true); + st_ansistring: + emitcall(procedureprefix+'STRANSI',true); + st_shortstring: + emitcall(procedureprefix+'SSTRING',true); + st_longstring: + emitcall(procedureprefix+'STRLONG',true); + end; + disposetree(node); + p^.left := nil; + + {restore the addresses loaded by secondpass} + popusedregisters(pushed2); + {reload esi in case the dest_para/code_para is a class variable or so} + maybe_loadesi; + + If has_code and Not(has_32bit_code) Then + {only 16bit code is possible} + Begin + exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,NewReference(hr),R_EDI))); + emit_mov_reg_loc(R_DI,code_para^.left^.location); + Disposetree(code_para); + End; + + {save the function result in the destinatin variable} + Case dest_para^.left^.resulttype^.deftype of + floatdef: floatstore(PFloatDef(dest_para^.left^.resulttype)^.typ, + dest_para^.left^.location.reference); + orddef: + Case PordDef(dest_para^.left^.resulttype)^.typ of + u8bit,s8bit: + emit_mov_reg_loc(R_AL,dest_para^.left^.location); + u16bit,s16bit: + emit_mov_reg_loc(R_AX,dest_para^.left^.location); + u32bit,s32bit: + emit_mov_reg_loc(R_EAX,dest_para^.left^.location); + {u64bit,s64bitint: ???} + End; + End; + If (cs_check_range in aktlocalswitches) and + (dest_para^.left^.resulttype^.deftype = orddef) and + {the following has to be changed to 64bit checking, once Val + returns 64 bit values (unless a special Val function is created + for that} + {no need to rangecheck longints or cardinals on 32bit processors} + not((porddef(dest_para^.left^.resulttype)^.typ = s32bit) and + (porddef(dest_para^.left^.resulttype)^.low = $80000000) and + (porddef(dest_para^.left^.resulttype)^.high = $7fffffff)) and + not((porddef(dest_para^.left^.resulttype)^.typ = u32bit) and + (porddef(dest_para^.left^.resulttype)^.low = 0) and + (porddef(dest_para^.left^.resulttype)^.high = $ffffffff)) then + Begin + If has_32bit_code then + {we don't have temporary variable space yet} + GetTempOfSizeReference(4,hr); + {save the result in a temp variable, because EAX may be + overwritten by popusedregs()} + exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EAX,NewReference(hr)))); + {clean up the stack, so a backtrace is possible if range check + fails} + popusedregisters(pushed); + {create a temporary 32bit location for the returned value} + hp := getcopy(dest_para^.left); + hp^.location.loc := LOC_REFERENCE; + hp^.location.reference := hr; + {do not register this temporary def} + OldRegisterDef := RegisterDef; + RegisterDef := False; + Case PordDef(dest_para^.left^.resulttype)^.typ of + u8bit,u16bit,u32bit: new(hdef,init(u32bit,0,$fffffff)); + s8bit,s16bit,s32bit: new(hdef,init(s32bit,$fffffff,$7ffffff)); + end; + hp^.resulttype := hdef; + emitrangecheck(hp,dest_para^.left^.resulttype); + hp^.right := nil; + Dispose(hp^.resulttype, Done); + RegisterDef := OldRegisterDef; + disposetree(hp); + {it's possible that the range cheking was handled by a + procedure that has destroyed ESI} + maybe_loadesi; + End + Else + {clean up the stack} + popusedregisters(pushed); + {dest_para^right is already nil} + disposetree(dest_para); + UnGetIfTemp(hr); + end; +{$EndIf ValIntern} + var r : preference; hp : ptree; @@ -943,6 +1219,12 @@ implementation handle_str; maybe_loadesi; end; +{$IfDef ValIntern} + in_val_x : + Begin + handle_val; + End; +{$EndIf ValIntern} in_include_x_y, in_exclude_x_y: begin @@ -1027,7 +1309,12 @@ implementation end. { $Log$ - Revision 1.29 1999-02-25 21:02:27 peter + Revision 1.30 1999-03-16 17:52:56 jonas + * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test) + * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck") + * in cgai386: also small fixes to emitrangecheck + + Revision 1.29 1999/02/25 21:02:27 peter * ag386bin updates + coff writer diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index ed2ccb0ca7..8e12f9e14f 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -417,6 +417,29 @@ unit pexpr; pd:=voiddef; end; +{$IfDef ValIntern} + in_val_x: + Begin + consume(LKLAMMER); + in_args := true; + p1:= gencallparanode(comp_expr(true), nil); + Must_be_valid := False; + consume(COMMA); + p2 := gencallparanode(comp_expr(true),p1); + if (token = COMMA) then + Begin + consume(COMMA); + p2 := gencallparanode(comp_expr(true),p2) + End; + consume(RKLAMMER); + p2 := geninlinenode(l,false,p2); + do_firstpass(p2); + statement_syssym := p2; + pd := voiddef; + End; +{$EndIf ValIntern} + + in_include_x_y, in_exclude_x_y : begin @@ -1936,7 +1959,12 @@ unit pexpr; end. { $Log$ - Revision 1.86 1999-03-04 13:55:44 pierre + Revision 1.87 1999-03-16 17:52:52 jonas + * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test) + * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck") + * in cgai386: also small fixes to emitrangecheck + + Revision 1.86 1999/03/04 13:55:44 pierre * some m68k fixes (still not compilable !) * new(tobj) does not give warning if tobj has no VMT ! diff --git a/compiler/psystem.pas b/compiler/psystem.pas index 59b6492777..8736e7a932 100644 --- a/compiler/psystem.pas +++ b/compiler/psystem.pas @@ -63,6 +63,9 @@ begin p^.insert(new(psyssym,init('INC',in_inc_x))); p^.insert(new(psyssym,init('STR',in_str_x_string))); p^.insert(new(psyssym,init('ASSERT',in_assert_x_y))); +{$IfDef ValIntern} + p^.insert(new(psyssym,init('VAL',in_val_x))); +{$EndIf ValIntern} end; @@ -253,7 +256,12 @@ end; end. { $Log$ - Revision 1.16 1999-03-02 02:56:17 peter + Revision 1.17 1999-03-16 17:52:54 jonas + * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test) + * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck") + * in cgai386: also small fixes to emitrangecheck + + Revision 1.16 1999/03/02 02:56:17 peter + stabs support for binary writers * more fixes and missing updates from the previous commit :( diff --git a/compiler/tcinl.pas b/compiler/tcinl.pas index b7dcb2d40c..069ab9ad00 100644 --- a/compiler/tcinl.pas +++ b/compiler/tcinl.pas @@ -106,6 +106,9 @@ implementation count_ref:=false; if not (p^.inlinenumber in [in_read_x,in_readln_x,in_sizeof_x, in_typeof_x,in_ord_x,in_str_x_string, +{$IfDef ValIntern} + in_val_x, +{$EndIf ValIntern} in_reset_typedfile,in_rewrite_typedfile]) then must_be_valid:=true else @@ -807,6 +810,73 @@ implementation { calc registers } left_right_max(p); end; +{$IfDef ValIntern} + + in_val_x : + begin + procinfo.flags:=procinfo.flags or pi_do_call; + p^.resulttype:=voiddef; + { check the amount of parameters } + if not(assigned(p^.left)) or + not(assigned(p^.left^.right)) then + begin + CGMessage(parser_e_wrong_parameter_size); + exit; + end; + If Assigned(p^.left^.right^.right) Then + {there is a "code" parameter} + Begin + { first pass just the code parameter for first local use} + hp := p^.left^.right; + p^.left^.right := nil; + must_be_valid := false; + count_ref := true; + firstcallparan(p^.left, nil); + if codegenerror then exit; + p^.left^.right := hp; + {code has to be a var parameter} + if (p^.left^.left^.location.loc<>LOC_REFERENCE) then + CGMessage(type_e_variable_id_expected) + else + if (p^.left^.left^.resulttype^.deftype <> orddef) or + not(porddef(p^.left^.left^.resulttype)^.typ in + [u16bit,s16bit,u32bit,s32bit]) then + CGMessage(type_e_mismatch); + hpp := p^.left^.right + End + Else hpp := p^.left; + {now hpp = the destination value tree} + { first pass just the destination parameter for first local use} + hp:=hpp^.right; + must_be_valid:=false; + count_ref:=true; + hpp^.right:=nil; + {hpp = destination} + firstcallparan(hpp,nil); + if codegenerror then exit; + hpp^.right := hp; + if (hpp^.left^.location.loc<>LOC_REFERENCE) then + CGMessage(type_e_variable_id_expected) + else + If Not((hpp^.left^.resulttype^.deftype = floatdef) or + ((hpp^.left^.resulttype^.deftype = orddef) And + (POrdDef(hpp^.left^.resulttype)^.typ in + [u32bit,s32bit,{s64bitint,u64bit, -- not supported yet in RTL} + u8bit,s8bit,u16bit,s16bit]))) + Then CGMessage(type_e_mismatch); + must_be_valid:=true; + {hp = source (String)} + count_ref := false; + must_be_valid := true; + firstcallparan(hp,nil); + if codegenerror then exit; + If (hp^.resulttype^.deftype<>stringdef) then + CGMessage(type_e_mismatch); +{ firstcallparan(p^.left,nil);} + { calc registers } + left_right_max(p); + end; +{$EndIf ValIntern} in_include_x_y, in_exclude_x_y: begin @@ -978,7 +1048,12 @@ implementation end. { $Log$ - Revision 1.19 1999-02-22 12:36:34 florian + Revision 1.20 1999-03-16 17:52:55 jonas + * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test) + * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck") + * in cgai386: also small fixes to emitrangecheck + + Revision 1.19 1999/02/22 12:36:34 florian + warning for lo/hi(longint/dword) in -So and -Sd mode added Revision 1.18 1999/02/22 02:15:49 peter