paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-02 08:29:32 +01:00
Code Issues Packages Projects Releases Wiki Activity

+ subrange checking for readln()

Browse Source
This commit is contained in:
peter 1999-04-08 15:57:44 +00:00
parent b731de8bdd
commit dda7bf2bc9
9 changed files with 438 additions and 293 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bugs/bug0185.pp
View File

@ -6,7 +6,6 @@ var s: String;
i: integer;
code: word;
e: 0..10;
enum : (a,b,c,d);
Begin
{$R-}
@ -29,7 +28,4 @@ Begin
val(s, i, code); {must give a range check error}
Writeln('Val range check failed!');
{ val must also handle enums }
s:='2';
val(s, enum, code);
End.

8
bugs/readme.txt
View File

@ -10,6 +10,8 @@ In future, please add also your name short cut, when fixing a bug.
Fixed bugs:
-----------
1.pp produces a linker error under win32/linux, sorry for the filename
but the filename is the bug :) OK 0.99.11 (PFV)
bug0001.pp tests a bug in the .ascii output (#0 and too long) OK 0.9.2
bug0002.pp tests for the endless bug in the optimizer OK 0.9.2
bug0003.pp dito OK 0.9.2
@ -223,6 +225,7 @@ Fixed bugs:
bug0182.pp @record.field doesn't work in constant expr OK 0.99.9 (PM)
bug0183.pp internal error 10 in secondnot OK 0.99.11 (PM)
bug0184.pp multiple copies of the same constant set are stored in executable OK 0.99.9 (PFV)
bug0185.pp missing range checking for Val and subrange types OK 0.99.11 (JM/PFV)
bug0186.pp Erroneous array syntax is accepted. OK 0.99.9 (PFV)
bug0187.pp constructor in a WIth statement isn't called correct.
(works at lest in the case stated) OK 0.99.11 (PM)
@ -280,8 +283,7 @@ Fixed bugs:
bug0229.pp consts > 255 are truncated (should work in -S2,-Sd) OK 0.99.11 (PFV)
bug0231.pp Problem with comments OK 0.99.11 (PFV)
bug0233.pp Problem with enum sets in args OK 0.99.11 (PFV)
1.pp produces a linker error under win32/linux, sorry for the filename
but the filename is the bug :) OK 0.99.11 (PFV)
bug0235.pp Val(cardinal) bug OK 0.99.11 (JM)
Unproducable bugs:
@ -311,12 +313,10 @@ bug0124.pp Asm, problem with -Rintel switch and indexing (whatever the order)
bug0226.pp Asm, offset of var is not allowed as constant
bug0228.pp Asm, wrong warning for size
bug0185.pp missing range checking for Val and subrange types
bug0217.pp in tp mode can't use the procvar in writeln
bug0230.pp several strange happen on the ln function: ln(0): no
FPE and writeln can't write non numeric values
bug0232.pp const. procedure variables need a special syntax
if they use calling specification modifiers
bug0234.pp New with void pointer
bug0235.pp Val(cardinal) bug
bug0236.pp Problem with range check of subsets !! compile with -Cr

383
compiler/cg386inl.pas
View File

@ -77,6 +77,75 @@ implementation
SecondInLine
*****************************************************************************}
procedure StoreDirectFuncResult(dest:ptree);
var
hp : ptree;
hdef : porddef;
hreg : tregister;
oldregisterdef : boolean;
begin
SecondPass(dest);
if Codegenerror then
exit;
Case dest^.resulttype^.deftype of
floatdef:
floatstore(PFloatDef(dest^.resulttype)^.typ,dest^.location.reference);
orddef:
begin
Case dest^.resulttype^.size of
1 : hreg:=regtoreg8(accumulator);
2 : hreg:=regtoreg16(accumulator);
4 : hreg:=accumulator;
End;
emit_mov_reg_loc(hreg,dest^.location);
If (cs_check_range in aktlocalswitches) and
{no need to rangecheck longints or cardinals on 32bit processors}
not((porddef(dest^.resulttype)^.typ = s32bit) and
(porddef(dest^.resulttype)^.low = $80000000) and
(porddef(dest^.resulttype)^.high = $7fffffff)) and
not((porddef(dest^.resulttype)^.typ = u32bit) and
(porddef(dest^.resulttype)^.low = 0) and
(porddef(dest^.resulttype)^.high = $ffffffff)) then
Begin
{do not register this temporary def}
OldRegisterDef := RegisterDef;
RegisterDef := False;
hdef:=nil;
Case PordDef(dest^.resulttype)^.typ of
u8bit,u16bit,u32bit:
begin
new(hdef,init(u32bit,0,$ffffffff));
hreg:=accumulator;
end;
s8bit,s16bit,s32bit:
begin
new(hdef,init(s32bit,$80000000,$7fffffff));
hreg:=accumulator;
end;
end;
{ create a fake node }
hp := genzeronode(nothingn);
hp^.location.loc := LOC_REGISTER;
hp^.location.register := hreg;
if assigned(hdef) then
hp^.resulttype:=hdef
else
hp^.resulttype:=dest^.resulttype;
{ emit the range check }
emitrangecheck(hp,dest^.resulttype);
hp^.right := nil;
if assigned(hdef) then
Dispose(hdef, Done);
RegisterDef := OldRegisterDef;
disposetree(hp);
End;
End;
else
internalerror(66766766);
end;
end;
procedure secondinline(var p : ptree);
const
{ tfloattype = (f32bit,s32real,s64real,s80real,s64bit); }
@ -100,18 +169,21 @@ implementation
procedure loadstream;
const
io:array[0..1] of string[7]=('_OUTPUT','_INPUT');
io:array[boolean] of string[7]=('_OUTPUT','_INPUT');
var
r : preference;
begin
new(r);
reset_reference(r^);
r^.symbol:=newasmsymbol('U_'+upper(target_info.system_unit)+io[byte(doread)]);
r^.symbol:=newasmsymbol('U_'+upper(target_info.system_unit)+io[doread]);
concat_external(r^.symbol^.name,EXT_NEAR);
exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,r,R_EDI)))
end;
const
rdwrprefix:array[boolean] of string[15]=('FPC_WRITE_TEXT_','FPC_READ_TEXT_');
var
destpara,
node,hp : ptree;
typedtyp,
pararesult : pdef;
@ -119,7 +191,6 @@ implementation
dummycoll : tdefcoll;
iolabel : plabel;
npara : longint;
begin
{ I/O check }
if (cs_check_io in aktlocalswitches) and
@ -208,16 +279,25 @@ implementation
hp^.right:=nil;
if hp^.is_colon_para then
CGMessage(parser_e_illegal_colon_qualifier);
if ft=ft_typed then
never_copy_const_param:=true;
{ reset data type }
dummycoll.data:=nil;
{ support openstring calling for readln(shortstring) }
if doread and (is_shortstring(hp^.resulttype)) then
dummycoll.data:=openshortstringdef;
secondcallparan(hp,@dummycoll,false,false,0);
if ft=ft_typed then
never_copy_const_param:=false;
{ when read ord,floats are functions, so they need this
parameter as their destination instead of being pushed }
if doread and
(ft<>ft_typed) and
(hp^.resulttype^.deftype in [orddef,floatdef]) then
destpara:=hp^.left
else
begin
if ft=ft_typed then
never_copy_const_param:=true;
{ reset data type }
dummycoll.data:=nil;
{ support openstring calling for readln(shortstring) }
if doread and (is_shortstring(hp^.resulttype)) then
dummycoll.data:=openshortstringdef;
secondcallparan(hp,@dummycoll,false,false,0);
if ft=ft_typed then
never_copy_const_param:=false;
end;
hp^.right:=node;
if codegenerror then
exit;
@ -287,7 +367,11 @@ implementation
end
end;
case pararesult^.deftype of
stringdef : begin
stringdef :
begin
{$ifndef OLDREAD}
emitcall(rdwrprefix[doread]+pstringdef(pararesult)^.stringtypname,true);
{$else}
if doread then
begin
{ push maximum string length }
@ -313,136 +397,78 @@ implementation
st_widestring:
emitcall ('FPC_WRITE_TEXT_ANSISTRING',true);
end;
end;
pointerdef : begin
if is_equal(ppointerdef(pararesult)^.definition,cchardef) then
begin
if doread then
emitcall('FPC_READ_TEXT_PCHAR_AS_POINTER',true)
else
emitcall('FPC_WRITE_TEXT_PCHAR_AS_POINTER',true);
end;
end;
arraydef : begin
if is_chararray(pararesult) then
begin
if doread then
emitcall('FPC_READ_TEXT_PCHAR_AS_ARRAY',true)
else
emitcall('FPC_WRITE_TEXT_PCHAR_AS_ARRAY',true);
end;
end;
floatdef : begin
if doread then
emitcall('FPC_READ_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true)
else
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
{$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
{$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
{$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
{$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
{$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
{$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
{$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:
if doread then
emitcall('FPC_READ_TEXT_INT64',true)
else
emitcall('FPC_WRITE_TEXT_INT64',true);
u64bit : if doread then
emitcall('FPC_READ_TEXT_QWORD',true)
else
emitcall('FPC_WRITE_TEXT_QWORD',true);
bool8bit,
bool16bit,
bool32bit : if doread then
CGMessage(parser_e_illegal_parameter_list)
else
emitcall('FPC_WRITE_TEXT_BOOLEAN',true);
end;
end;
{$endif}
end;
pointerdef :
begin
if is_pchar(pararesult) then
emitcall(rdwrprefix[doread]+'PCHAR_AS_POINTER',true)
end;
arraydef :
begin
if is_chararray(pararesult) then
emitcall(rdwrprefix[doread]+'PCHAR_AS_ARRAY',true)
end;
floatdef :
begin
{$ifndef OLDREAD}
if doread then
begin
emitcall(rdwrprefix[doread]+'FLOAT',true);
StoreDirectFuncResult(destpara);
end
else
{$endif}
emitcall(rdwrprefix[doread]+float_name[pfloatdef(pararesult)^.typ],true)
end;
orddef :
begin
case porddef(pararesult)^.typ of
{$ifndef OLDREAD}
s8bit,s16bit,s32bit :
emitcall(rdwrprefix[doread]+'SINT',true);
u8bit,u16bit,u32bit :
emitcall(rdwrprefix[doread]+'UINT',true);
{$else}
u8bit :
if doread then
emitcall('FPC_READ_TEXT_BYTE',true);
s8bit :
if doread then
emitcall('FPC_READ_TEXT_SHORTINT',true);
u16bit :
if doread then
emitcall('FPC_READ_TEXT_WORD',true);
s16bit :
if doread then
emitcall('FPC_READ_TEXT_INTEGER',true);
s32bit :
if doread then
emitcall('FPC_READ_TEXT_LONGINT',true)
else
emitcall('FPC_WRITE_TEXT_LONGINT',true);
u32bit :
if doread then
emitcall('FPC_READ_TEXT_CARDINAL',true)
else
emitcall('FPC_WRITE_TEXT_CARDINAL',true);
{$endif}
uchar :
emitcall(rdwrprefix[doread]+'CHAR',true);
s64bitint:
emitcall(rdwrprefix[doread]+'INT64',true);
u64bit :
emitcall(rdwrprefix[doread]+'QWORD',true);
bool8bit,
bool16bit,
bool32bit :
emitcall(rdwrprefix[doread]+'BOOLEAN',true);
end;
{$ifndef OLDREAD}
if doread then
StoreDirectFuncResult(destpara);
{$endif}
end;
end;
end;
{ load ESI in methods again }
@ -528,19 +554,7 @@ implementation
dummycoll.data:=openshortstringdef
else
dummycoll.data:=hp^.resulttype;
case pstringdef(hp^.resulttype)^.string_typ of
st_widestring:
procedureprefix:='FPC_WIDESTR_';
st_ansistring:
procedureprefix:='FPC_ANSISTR_';
st_shortstring:
procedureprefix:='FPC_SHORTSTR_';
st_longstring:
procedureprefix:='FPC_LONGSTR_';
end;
procedureprefix:='FPC_'+pstringdef(hp^.resulttype)^.stringtypname+'_';
secondcallparan(hp,@dummycoll,false,false,0);
if codegenerror then
exit;
@ -718,16 +732,6 @@ implementation
emitpushreferenceaddr(exprasmlist,hr);
End;
Case dest_para^.resulttype^.deftype of
floatdef:
procedureprefix := 'FPC_VAL_REAL_';
orddef:
if is_signed(dest_para^.resulttype) then
procedureprefix := 'FPC_VAL_SINT_'
else
procedureprefix := 'FPC_VAL_UINT_';
End;
{node = first parameter = string}
dummycoll.paratyp:=vs_const;
dummycoll.data:=node^.resulttype;
@ -735,26 +739,22 @@ implementation
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_L,1)));
s16bit: exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,2)));
s32bit: exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,4)));
End;
case pstringdef(node^.resulttype)^.string_typ of
st_widestring:
emitcall(procedureprefix+'WIDESTR',true);
st_ansistring:
emitcall(procedureprefix+'ANSISTR',true);
st_shortstring:
emitcall(procedureprefix+'SHORTSTR',true);
st_longstring:
emitcall(procedureprefix+'LONGSTR',true);
end;
Case dest_para^.resulttype^.deftype of
floatdef:
procedureprefix := 'FPC_VAL_REAL_';
orddef:
if is_signed(dest_para^.resulttype) then
begin
{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}
exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,dest_para^.resulttype^.size)));
procedureprefix := 'FPC_VAL_SINT_'
end
else
procedureprefix := 'FPC_VAL_UINT_';
End;
emitcall(procedureprefix+pstringdef(node^.resulttype)^.stringtypname,true);
disposetree(node);
p^.left := nil;
@ -788,8 +788,8 @@ implementation
popusedregisters(pushed);
{save the function result in the destination variable}
Case dest_para^.left^.resulttype^.deftype of
floatdef: floatstore(PFloatDef(dest_para^.left^.resulttype)^.typ,
dest_para^.left^.location.reference);
floatdef:
floatstore(PFloatDef(dest_para^.left^.resulttype)^.typ,dest_para^.left^.location.reference);
orddef:
Case PordDef(dest_para^.left^.resulttype)^.typ of
u8bit,s8bit:
@ -1278,7 +1278,10 @@ implementation
end.
{
$Log$
Revision 1.39 1999-04-07 15:31:16 pierre
Revision 1.40 1999-04-08 15:57:46 peter
+ subrange checking for readln()
Revision 1.39 1999/04/07 15:31:16 pierre
* all formaldefs are now a sinlge definition
cformaldef (this was necessary for double_checksum)
+ small part of double_checksum code

15
compiler/symdef.inc
View File

@ -525,6 +525,16 @@
end;
function tstringdef.stringtypname:string;
const
typname:array[tstringtype] of string[8]=(
'SHORTSTR','LONGSTR','ANSISTR','WIDESTR'
);
begin
stringtypname:=typname[string_typ];
end;
function tstringdef.size : longint;
begin
size:=savesize;
@ -3423,7 +3433,10 @@ Const local_symtable_index : longint = $8001;
{
$Log$
Revision 1.99 1999-04-07 15:39:32 pierre
Revision 1.100 1999-04-08 15:57:51 peter
+ subrange checking for readln()
Revision 1.99 1999/04/07 15:39:32 pierre
+ double_checksum code added
Revision 1.98 1999/03/06 17:24:16 peter

6
compiler/symdefh.inc
View File

@ -444,6 +444,7 @@
constructor ansiload;
constructor wideinit(l : longint);
constructor wideload;
function stringtypname:string;
function size : longint;virtual;
procedure write;virtual;
{$ifdef GDB}
@ -505,7 +506,10 @@
{
$Log$
Revision 1.18 1999-03-02 18:24:21 peter
Revision 1.19 1999-04-08 15:57:52 peter
+ subrange checking for readln()
Revision 1.18 1999/03/02 18:24:21 peter
* fixed overloading of array of char
Revision 1.17 1999/03/01 13:45:06 pierre

13
rtl/inc/astrings.inc
View File

@ -490,7 +490,7 @@ end;
{$IfDef ValInternCompiled}
Function ValAnsiFloat(Const S : AnsiString; Var Code : TMaxSInt): ValReal; [public, alias:'FPC_VAL_REAL_ANSISTR'];
Function ValAnsiFloat(Const S : AnsiString; Var Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_ANSISTR'];
Var SS : String;
begin
AnsiStr_To_ShortStr(SS,Pointer(S));
@ -498,7 +498,7 @@ begin
end;
Function ValAnsiUnsigendInt (Const S : AnsiString; Code : TMaxSInt): TMaxUInt; [public, alias:'FPC_VAL_UINT_ANSISTR'];
Function ValAnsiUnsigendInt (Const S : AnsiString; Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_ANSISTR'];
Var SS : ShortString;
begin
@ -507,7 +507,7 @@ begin
end;
Function ValAnsiSignedInt (DestSize: Byte; Const S : AnsiString; Var Code : TMaxSInt): TMaxSInt; [public, alias:'FPC_VAL_SINT_ANSISTR'];
Function ValAnsiSignedInt (DestSize: Byte; Const S : AnsiString; Var Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_ANSISTR'];
Var SS : ShortString;
@ -517,7 +517,7 @@ begin
end;
{$IfDef SUPPORT_FIXED}
Function ValAnsiFixed(Const S : AnsiString; Var Code : TMaxSint): ValReal; [public, alias:'FPC_VAL_FIXED_ANSISTR'];
Function ValAnsiFixed(Const S : AnsiString; Var Code : ValSint): ValReal; [public, alias:'FPC_VAL_FIXED_ANSISTR'];
Var SS : String;
begin
AnsiStr_To_ShortStr (SS,Pointer(S));
@ -764,7 +764,10 @@ end;
{
$Log$
Revision 1.18 1999-04-08 10:19:55 peter
Revision 1.19 1999-04-08 15:57:53 peter
+ subrange checking for readln()
Revision 1.18 1999/04/08 10:19:55 peter
* fixed concat when s1 or s2 was nil
Revision 1.17 1999/04/06 11:23:58 peter

38
rtl/inc/sstrings.inc
View File

@ -344,12 +344,7 @@ end;
Val() Functions
*****************************************************************************}
Function InitVal(const s:shortstring;var negativ:boolean;var base:byte):
{$IfDef ValInternCompiled}
TMaxSInt;
{$Else ValInternCompiled}
Word;
{$EndIf ValInternCompiled}
Function InitVal(const s:shortstring;var negativ:boolean;var base:byte):ValSInt;
var
Code : Longint;
begin
@ -394,12 +389,12 @@ end;
{$IfDef ValInternCompiled}
Function ValSignedInt(DestSize: longint; Const S: ShortString; var Code: TMaxSInt): TMaxSInt; [public, alias:'FPC_VAL_SINT_SHORTSTR'];
Function ValSignedInt(DestSize: longint; Const S: ShortString; var Code: ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_SHORTSTR'];
var
u: TMaxSInt;
u: ValSInt;
base : byte;
negative : boolean;
temp, prev: TMaxUInt;
temp, prev: ValUInt;
begin
ValSignedInt := 0;
Temp:=0;
@ -423,9 +418,9 @@ begin
u:=16;
end;
Prev := Temp;
Temp := Temp*TMaxUInt(base);
Temp := Temp*ValUInt(base);
If ((base = 10) and
(prev > MaxSIntValue div TMaxUInt(Base))) or
(prev > MaxSIntValue div ValUInt(Base))) or
(Temp < prev) Then
Begin
ValSignedInt := 0;
@ -444,7 +439,7 @@ begin
inc(code);
end;
code := 0;
ValSignedInt := TMaxSInt(Temp);
ValSignedInt := ValSInt(Temp);
If Negative Then
ValSignedInt := -ValSignedInt;
If Not(Negative) and (base <> 10) Then
@ -460,12 +455,12 @@ begin
End;
end;
Function ValUnsignedInt(Const S: ShortString; var Code: TMaxSInt): TMaxUInt; [public, alias:'FPC_VAL_UINT_SHORTSTR'];
Function ValUnsignedInt(Const S: ShortString; var Code: ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_SHORTSTR'];
var
u: TMaxUInt;
u: ValUInt;
base : byte;
negative : boolean;
prev: TMaxUInt;
prev: ValUInt;
begin
ValUnSignedInt:=0;
Code:=InitVal(s,negative,base);
@ -481,10 +476,10 @@ begin
u:=16;
end;
prev := ValUnsignedInt;
ValUnsignedInt:=ValUnsignedInt*TMaxUInt(base);
ValUnsignedInt:=ValUnsignedInt*ValUInt(base);
If prev > ValUnsignedInt Then
{we've had an overflow. Can't check this with
"If ValUnsignedInt <= (MaxUIntValue div TMaxUInt(Base)) Then"
"If ValUnsignedInt <= (MaxUIntValue div ValUInt(Base)) Then"
because this division always overflows! (JM)}
Begin
ValUnsignedInt := 0;
@ -501,7 +496,7 @@ begin
code := 0;
end;
Function ValFloat(const s : shortstring; var code : TMaxSInt): ValReal; [public, alias:'FPC_VAL_REAL_SHORTSTR'];
Function ValFloat(const s : shortstring; var code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_SHORTSTR'];
var
hd,
esign,sign : valreal;
@ -595,7 +590,7 @@ begin
end;
{$ifdef SUPPORT_FIXED}
Function ValFixed(const s : shortstring;var code : TMaxSInt): Fixed; [public, alias:'FPC_VAL_FIXED_SHORTSTR'];
Function ValFixed(const s : shortstring;var code : ValSInt): Fixed; [public, alias:'FPC_VAL_FIXED_SHORTSTR'];
begin
ValFixed := Fixed(ValFloat(s,code));
end;
@ -1195,7 +1190,10 @@ end;
{
$Log$
Revision 1.26 1999-04-05 12:28:27 michael
Revision 1.27 1999-04-08 15:57:54 peter
+ subrange checking for readln()
Revision 1.26 1999/04/05 12:28:27 michael
+ Fixed insert with char. length byte wrapped around in some cases.
Revision 1.25 1999/04/01 22:11:50 peter

40
rtl/inc/systemh.inc
View File

@ -47,33 +47,28 @@ Type
{ at least declare Turbo Pascal real types }
{$ifdef i386}
StrLenInt = LongInt;
Double = real;
StrLenInt = LongInt;
{$define DEFAULT_EXTENDED}
{$define SUPPORT_EXTENDED}
{$define SUPPORT_COMP}
{$define SUPPORT_SINGLE}
{causes internalerror(17) with internal val handling, and is not yet fully
supported anyway (JM)}
{causes internalerror(17) with internal val handling, and is not yet fully
supported anyway (JM)}
{ define SUPPORT_FIXED}
Double = real;
{$IfDef ValInternCompiled}
TMaxSInt = Longint;
TMaxUInt = Cardinal;
{$EndIf ValInternCompiled}
{$ifdef DEFAULT_EXTENDED}
ValReal = Extended;
{$else}
ValReal = Double;
{$endif}
ValSInt = Longint;
ValUInt = Cardinal;
ValReal = Extended;
{$endif}
{$ifdef m68k}
TMaxSInt = Longint;
TMaxUInt = Cardinal;
StrLenInt = Longint;
ValReal = Real;
StrLenInt = Longint;
ValSInt = Longint;
ValUInt = Cardinal;
ValReal = Real;
{$endif}
{ some type aliases }
@ -90,8 +85,8 @@ Type
const
{$IfDef ValInternCompiled}
{ Maximum value of the biggest signed and unsigned integer type available}
MaxSIntValue = High(TMaxSInt);
MaxUIntValue = High(TMaxUInt);
MaxSIntValue = High(ValSInt);
MaxUIntValue = High(ValUInt);
{$EndIf ValInternCompiled}
@ -457,7 +452,10 @@ const
{
$Log$
Revision 1.53 1999-03-16 17:49:37 jonas
Revision 1.54 1999-04-08 15:57:56 peter
+ subrange checking for readln()
Revision 1.53 1999/03/16 17:49:37 jonas
* changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)
* in text.inc: changed RTE 106 when read integer values are out of bounds to RTE 201
* in systemh.inc: disabled "support_fixed" for the i386 because it gave internal errors,

224
rtl/inc/text.inc
View File

@ -433,7 +433,7 @@ begin
end;
Procedure Write_Str(Len : Longint;var f : TextRec;const s : String);[Public,Alias:'FPC_WRITE_TEXT_STRING'];
Procedure Write_Str(Len : Longint;var f : TextRec;const s : String);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef NEWREADINT}'SHORTSTR'{$else}'STRING'{$endif}];
Begin
If (InOutRes<>0) then
exit;
@ -486,7 +486,7 @@ Begin
End;
Procedure Write_Text_AnsiString (Len : Longint; Var T : TextRec; S : Pointer);[Public,alias:'FPC_WRITE_TEXT_ANSISTRING'];
Procedure Write_Text_AnsiString (Len : Longint; Var T : TextRec; S : Pointer);[Public,alias:'FPC_WRITE_TEXT_'+{$ifdef NEWREADINT}'ANSISTR'{$else}'ANSISTRING'{$endif}];
{
Writes a AnsiString to the Text file T
}
@ -497,7 +497,7 @@ begin
end;
Procedure Write_LongInt(Len : Longint;var t : TextRec;l : Longint);[Public,Alias:'FPC_WRITE_TEXT_LONGINT'];
Procedure Write_SInt(Len : Longint;var t : TextRec;l : ValSInt);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef NEWREADINT}'SINT'{$else}'LONGINT'{$endif}];
var
s : String;
Begin
@ -508,6 +508,18 @@ Begin
End;
Procedure Write_UInt(Len : Longint;var t : TextRec;l : ValUInt);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef NEWREADINT}'UINT'{$else}'CARDINAL'{$endif}];
var
s : String;
Begin
If (InOutRes<>0) then
exit;
Str(L,s);
Write_Str(Len,t,s);
End;
Procedure Write_Real(fixkomma,Len : Longint;var t : TextRec;r : real);[Public,Alias:'FPC_WRITE_TEXT_REAL'];
var
s : String;
@ -523,17 +535,6 @@ Begin
End;
Procedure Write_Cardinal(Len : Longint;var t : TextRec;l : cardinal);[Public,Alias:'FPC_WRITE_TEXT_CARDINAL'];
var
s : String;
Begin
If (InOutRes<>0) then
exit;
Str(L,s);
Write_Str(Len,t,s);
End;
{$ifdef SUPPORT_SINGLE}
Procedure Write_Single(fixkomma,Len : Longint;var t : TextRec;r : single);[Public,Alias:'FPC_WRITE_TEXT_SINGLE'];
var
@ -732,7 +733,7 @@ Begin
End;
Procedure Read_String(var f : TextRec;var s : String);[Public,Alias:'FPC_READ_TEXT_STRING'];
Procedure Read_String(var f : TextRec;var s : String);[Public,Alias:'FPC_READ_TEXT_'+{$ifdef NEWREADINT}'SHORTSTR'{$else}'STRING'{$endif}];
var
maxlen,
sPos,len : Longint;
@ -788,32 +789,6 @@ Begin
End;
Procedure Read_Char(var f : TextRec;var c : Char);[Public,Alias:'FPC_READ_TEXT_CHAR'];
Begin
c:=#0;
{ Check error and if file is open }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
begin
InOutRes:=104;
exit;
end;
{ Read next char or EOF }
If f.BufPos>=f.BufEnd Then
begin
FileFunc(f.InOutFunc)(f);
If f.BufPos>=f.BufEnd Then
begin
c:=#26;
exit;
end;
end;
c:=f.Bufptr^[f.BufPos];
inc(f.BufPos);
end;
Procedure Read_PChar(var f : TextRec;var s : PChar);[Public,Alias:'FPC_READ_TEXT_PCHAR_AS_POINTER'];
var
p,maxp,startp,sidx : PChar;
@ -851,7 +826,7 @@ Begin
Move(startp^,sidx^,Len);
inc(sidx,len);
{ was it a LF? then leave }
if p^=#10 then
if (p<maxp) and (p^=#10) then
begin
If pchar(p-1)^=#13 Then
dec(p);
@ -899,7 +874,7 @@ Begin
Move(startp^,sidx^,Len);
inc(sidx,len);
{ was it a LF? then leave }
if p^=#10 then
if (p<maxp) and (p^=#10) then
begin
If pchar(p-1)^=#13 Then
dec(p);
@ -910,7 +885,7 @@ Begin
End;
Procedure Read_AnsiString(var f : TextRec;var s : AnsiString);[Public,Alias:'FPC_READ_TEXT_ANSISTRING'];
Procedure Read_AnsiString(var f : TextRec;var s : AnsiString);[Public,Alias:'FPC_READ_TEXT_'+{$ifdef NEWREADINT}'ANSISTR'{$else}'ANSISTRING'{$endif}];
var
p,maxp,startp,sidx : PChar;
maxlen,spos,len : longint;
@ -954,7 +929,7 @@ Begin
inc(sidx,len);
inc(spos,len);
{ was it a LF? then leave }
if p^=#10 then
if (p<maxp) and (p^=#10) then
begin
If pchar(sidx-1)^=#13 Then
begin
@ -972,6 +947,156 @@ Begin
End;
{$ifdef NEWREADINT}
Function Read_Char(var f : TextRec):char;[Public,Alias:'FPC_READ_TEXT_CHAR'];
Begin
Read_Char:=#0;
{ Check error and if file is open }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
begin
InOutRes:=104;
exit;
end;
{ Read next char or EOF }
If f.BufPos>=f.BufEnd Then
begin
FileFunc(f.InOutFunc)(f);
If f.BufPos>=f.BufEnd Then
exit(#26);
end;
Read_Char:=f.Bufptr^[f.BufPos];
inc(f.BufPos);
end;
Function Read_SInt(var f : TextRec):ValSInt;[Public,Alias:'FPC_READ_TEXT_SINT'];
var
hs : String;
code : Longint;
base : longint;
Begin
Read_SInt:=0;
{ Leave if error or not open file, else check for empty buf }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
begin
InOutRes:=104;
exit;
end;
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
hs:='';
if IgnoreSpaces(f) and ReadSign(f,hs) and ReadBase(f,hs,Base) then
ReadNumeric(f,hs,Base);
Val(hs,Read_SInt,code);
If code<>0 Then
InOutRes:=106;
End;
Function Read_UInt(var f : TextRec):ValUInt;[Public,Alias:'FPC_READ_TEXT_UINT'];
var
hs : String;
code : longint;
base : longint;
Begin
Read_UInt:=0;
{ Leave if error or not open file, else check for empty buf }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
begin
InOutRes:=104;
exit;
end;
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
hs:='';
if IgnoreSpaces(f) and ReadSign(f,hs) and ReadBase(f,hs,Base) then
ReadNumeric(f,hs,Base);
val(hs,Read_UInt,code);
If code<>0 Then
InOutRes:=106;
End;
Function Read_Float(var f : TextRec):ValReal;[Public,Alias:'FPC_READ_TEXT_FLOAT'];
var
hs : string;
code : Word;
begin
Read_Float:=0.0;
{ Leave if error or not open file, else check for empty buf }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
begin
InOutRes:=104;
exit;
end;
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
hs:='';
if IgnoreSpaces(f) and ReadSign(f,hs) and ReadNumeric(f,hs,10) then
begin
{ First check for a . }
if (f.Bufptr^[f.BufPos]='.') and (f.BufPos<f.BufEnd) Then
begin
hs:=hs+'.';
Inc(f.BufPos);
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
ReadNumeric(f,hs,10);
end;
{ Also when a point is found check for a E }
if (f.Bufptr^[f.BufPos] in ['e','E']) and (f.BufPos<f.BufEnd) Then
begin
hs:=hs+'E';
Inc(f.BufPos);
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
if ReadSign(f,hs) then
ReadNumeric(f,hs,10);
end;
end;
val(hs,Read_Float,code);
If code<>0 Then
InOutRes:=106;
end;
{$else}
Procedure Read_Char(var f : TextRec;var c : Char);[Public,Alias:'FPC_READ_TEXT_CHAR'];
Begin
c:=#0;
{ Check error and if file is open }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
begin
InOutRes:=104;
exit;
end;
{ Read next char or EOF }
If f.BufPos>=f.BufEnd Then
begin
FileFunc(f.InOutFunc)(f);
If f.BufPos>=f.BufEnd Then
begin
c:=#26;
exit;
end;
end;
c:=f.Bufptr^[f.BufPos];
inc(f.BufPos);
end;
Procedure Read_Longint(var f : TextRec;var l : Longint);[Public,Alias:'FPC_READ_TEXT_LONGINT'];
var
hs : String;
@ -1080,7 +1205,7 @@ Begin
ReadNumeric(f,hs,Base);
val(hs,l,code);
If code<>0 Then
InOutRes:=201;
InOutRes:=106;
End;
@ -1183,6 +1308,8 @@ Begin
End;
{$endif SUPPORT_FIXED}
{$endif}
{*****************************************************************************
Initializing
@ -1208,7 +1335,10 @@ end;
{
$Log$
Revision 1.43 1999-04-07 22:05:18 peter
Revision 1.44 1999-04-08 15:57:57 peter
+ subrange checking for readln()
Revision 1.43 1999/04/07 22:05:18 peter
* fixed bug with readln where it sometime didn't read until eol
Revision 1.42 1999/03/16 17:49:39 jonas