paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-04 09:19:39 +01:00
Code Issues Packages Projects Releases Wiki Activity

* changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)

Browse Source 
* in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck")
  * in cgai386: also small fixes to emitrangecheck
This commit is contained in:
Jonas Maebe 1999-03-16 17:52:52 +00:00
parent 228829bd86
commit 1e6d667c3b
4 changed files with 410 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

305
compiler/cg386inl.pas
View File

@ -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

30
compiler/pexpr.pas
View File

@ -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 !

10
compiler/psystem.pas
View File

@ -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 :(

77
compiler/tcinl.pas
View File

@ -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