paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-08 04:02:18 +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; i: integer;
code: word; code: word;
e: 0..10; e: 0..10;
enum : (a,b,c,d);
Begin Begin
{$R-} {$R-}
@ -29,7 +28,4 @@ Begin
val(s, i, code); {must give a range check error} val(s, i, code); {must give a range check error}
Writeln('Val range check failed!'); Writeln('Val range check failed!');
{ val must also handle enums }
s:='2';
val(s, enum, code);
End. 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: 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 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 bug0002.pp tests for the endless bug in the optimizer OK 0.9.2
bug0003.pp dito 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) 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) 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) 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) bug0186.pp Erroneous array syntax is accepted. OK 0.99.9 (PFV)
bug0187.pp constructor in a WIth statement isn't called correct. bug0187.pp constructor in a WIth statement isn't called correct.
(works at lest in the case stated) OK 0.99.11 (PM) (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) 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) bug0231.pp Problem with comments OK 0.99.11 (PFV)
bug0233.pp Problem with enum sets in args 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 bug0235.pp Val(cardinal) bug OK 0.99.11 (JM)
but the filename is the bug :) OK 0.99.11 (PFV)
Unproducable bugs: 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 bug0226.pp Asm, offset of var is not allowed as constant
bug0228.pp Asm, wrong warning for size 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 bug0217.pp in tp mode can't use the procvar in writeln
bug0230.pp several strange happen on the ln function: ln(0): no bug0230.pp several strange happen on the ln function: ln(0): no
FPE and writeln can't write non numeric values FPE and writeln can't write non numeric values
bug0232.pp const. procedure variables need a special syntax bug0232.pp const. procedure variables need a special syntax
if they use calling specification modifiers if they use calling specification modifiers
bug0234.pp New with void pointer bug0234.pp New with void pointer
bug0235.pp Val(cardinal) bug
bug0236.pp Problem with range check of subsets !! compile with -Cr bug0236.pp Problem with range check of subsets !! compile with -Cr

307
compiler/cg386inl.pas
View File

@ -77,6 +77,75 @@ implementation
SecondInLine 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); procedure secondinline(var p : ptree);
const const
{ tfloattype = (f32bit,s32real,s64real,s80real,s64bit); } { tfloattype = (f32bit,s32real,s64real,s80real,s64bit); }
@ -100,18 +169,21 @@ implementation
procedure loadstream; procedure loadstream;
const const
io:array[0..1] of string[7]=('_OUTPUT','_INPUT'); io:array[boolean] of string[7]=('_OUTPUT','_INPUT');
var var
r : preference; r : preference;
begin begin
new(r); new(r);
reset_reference(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); concat_external(r^.symbol^.name,EXT_NEAR);
exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,r,R_EDI))) exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,r,R_EDI)))
end; end;
const
rdwrprefix:array[boolean] of string[15]=('FPC_WRITE_TEXT_','FPC_READ_TEXT_');
var var
destpara,
node,hp : ptree; node,hp : ptree;
typedtyp, typedtyp,
pararesult : pdef; pararesult : pdef;
@ -119,7 +191,6 @@ implementation
dummycoll : tdefcoll; dummycoll : tdefcoll;
iolabel : plabel; iolabel : plabel;
npara : longint; npara : longint;
begin begin
{ I/O check } { I/O check }
if (cs_check_io in aktlocalswitches) and if (cs_check_io in aktlocalswitches) and
@ -208,6 +279,14 @@ implementation
hp^.right:=nil; hp^.right:=nil;
if hp^.is_colon_para then if hp^.is_colon_para then
CGMessage(parser_e_illegal_colon_qualifier); CGMessage(parser_e_illegal_colon_qualifier);
{ 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 if ft=ft_typed then
never_copy_const_param:=true; never_copy_const_param:=true;
{ reset data type } { reset data type }
@ -218,6 +297,7 @@ implementation
secondcallparan(hp,@dummycoll,false,false,0); secondcallparan(hp,@dummycoll,false,false,0);
if ft=ft_typed then if ft=ft_typed then
never_copy_const_param:=false; never_copy_const_param:=false;
end;
hp^.right:=node; hp^.right:=node;
if codegenerror then if codegenerror then
exit; exit;
@ -287,7 +367,11 @@ implementation
end end
end; end;
case pararesult^.deftype of case pararesult^.deftype of
stringdef : begin stringdef :
begin
{$ifndef OLDREAD}
emitcall(rdwrprefix[doread]+pstringdef(pararesult)^.stringtypname,true);
{$else}
if doread then if doread then
begin begin
{ push maximum string length } { push maximum string length }
@ -313,135 +397,77 @@ implementation
st_widestring: st_widestring:
emitcall ('FPC_WRITE_TEXT_ANSISTRING',true); emitcall ('FPC_WRITE_TEXT_ANSISTRING',true);
end; end;
{$endif}
end; end;
pointerdef : begin pointerdef :
if is_equal(ppointerdef(pararesult)^.definition,cchardef) then
begin begin
if doread then if is_pchar(pararesult) then
emitcall('FPC_READ_TEXT_PCHAR_AS_POINTER',true) emitcall(rdwrprefix[doread]+'PCHAR_AS_POINTER',true)
else
emitcall('FPC_WRITE_TEXT_PCHAR_AS_POINTER',true);
end; end;
end; arraydef :
arraydef : begin begin
if is_chararray(pararesult) then if is_chararray(pararesult) then
emitcall(rdwrprefix[doread]+'PCHAR_AS_ARRAY',true)
end;
floatdef :
begin begin
{$ifndef OLDREAD}
if doread then if doread then
emitcall('FPC_READ_TEXT_PCHAR_AS_ARRAY',true) begin
emitcall(rdwrprefix[doread]+'FLOAT',true);
StoreDirectFuncResult(destpara);
end
else else
emitcall('FPC_WRITE_TEXT_PCHAR_AS_ARRAY',true); {$endif}
emitcall(rdwrprefix[doread]+float_name[pfloatdef(pararesult)^.typ],true)
end; end;
end; orddef :
floatdef : begin 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 case porddef(pararesult)^.typ of
u8bit : if doread then {$ifndef OLDREAD}
{$IfDef ReadRangeCheck} s8bit,s16bit,s32bit :
Begin emitcall(rdwrprefix[doread]+'SINT',true);
{$EndIf ReadRangeCheck} u8bit,u16bit,u32bit :
emitcall(rdwrprefix[doread]+'UINT',true);
{$else}
u8bit :
if doread then
emitcall('FPC_READ_TEXT_BYTE',true); emitcall('FPC_READ_TEXT_BYTE',true);
{$IfDef ReadRangeCheck} s8bit :
If (porddef(pararesult)^.low <> 0) or if doread then
(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); emitcall('FPC_READ_TEXT_SHORTINT',true);
{$IfDef ReadRangeCheck} u16bit :
If (porddef(pararesult)^.low <> -128) or if doread then
(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); emitcall('FPC_READ_TEXT_WORD',true);
{$IfDef ReadRangeCheck} s16bit :
If (porddef(pararesult)^.low <> 0) or if doread then
(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); emitcall('FPC_READ_TEXT_INTEGER',true);
{$IfDef ReadRangeCheck} s32bit :
If (porddef(pararesult)^.low <> -32768) or if doread then
(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) 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 else
emitcall('FPC_WRITE_TEXT_LONGINT',true); emitcall('FPC_WRITE_TEXT_LONGINT',true);
u32bit : if doread then u32bit :
{$IfDef ReadRangeCheck} if doread then
Begin
{$EndIf ReadRangeCheck}
emitcall('FPC_READ_TEXT_CARDINAL',true) 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 else
emitcall('FPC_WRITE_TEXT_CARDINAL',true); emitcall('FPC_WRITE_TEXT_CARDINAL',true);
uchar : if doread then {$endif}
{$IfDef ReadRangeCheck} uchar :
Begin emitcall(rdwrprefix[doread]+'CHAR',true);
{$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: s64bitint:
if doread then emitcall(rdwrprefix[doread]+'INT64',true);
emitcall('FPC_READ_TEXT_INT64',true) u64bit :
else emitcall(rdwrprefix[doread]+'QWORD',true);
emitcall('FPC_WRITE_TEXT_INT64',true);
u64bit : if doread then
emitcall('FPC_READ_TEXT_QWORD',true)
else
emitcall('FPC_WRITE_TEXT_QWORD',true);
bool8bit, bool8bit,
bool16bit, bool16bit,
bool32bit : if doread then bool32bit :
CGMessage(parser_e_illegal_parameter_list) emitcall(rdwrprefix[doread]+'BOOLEAN',true);
else
emitcall('FPC_WRITE_TEXT_BOOLEAN',true);
end; end;
{$ifndef OLDREAD}
if doread then
StoreDirectFuncResult(destpara);
{$endif}
end; end;
end; end;
end; end;
@ -528,19 +554,7 @@ implementation
dummycoll.data:=openshortstringdef dummycoll.data:=openshortstringdef
else else
dummycoll.data:=hp^.resulttype; dummycoll.data:=hp^.resulttype;
case pstringdef(hp^.resulttype)^.string_typ of procedureprefix:='FPC_'+pstringdef(hp^.resulttype)^.stringtypname+'_';
st_widestring:
procedureprefix:='FPC_WIDESTR_';
st_ansistring:
procedureprefix:='FPC_ANSISTR_';
st_shortstring:
procedureprefix:='FPC_SHORTSTR_';
st_longstring:
procedureprefix:='FPC_LONGSTR_';
end;
secondcallparan(hp,@dummycoll,false,false,0); secondcallparan(hp,@dummycoll,false,false,0);
if codegenerror then if codegenerror then
exit; exit;
@ -718,16 +732,6 @@ implementation
emitpushreferenceaddr(exprasmlist,hr); emitpushreferenceaddr(exprasmlist,hr);
End; 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} {node = first parameter = string}
dummycoll.paratyp:=vs_const; dummycoll.paratyp:=vs_const;
dummycoll.data:=node^.resulttype; dummycoll.data:=node^.resulttype;
@ -735,26 +739,22 @@ implementation
if codegenerror then if codegenerror then
exit; exit;
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 {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 size of the destination, so the Val function can extend the sign
of the result to allow proper range checking} of the result to allow proper range checking}
If (dest_para^.resulttype^.deftype = orddef) Then exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,dest_para^.resulttype^.size)));
Case PordDef(dest_para^.resulttype)^.typ of procedureprefix := 'FPC_VAL_SINT_'
s8bit: exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,1))); end
s16bit: exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,2))); else
s32bit: exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,4))); procedureprefix := 'FPC_VAL_UINT_';
End; End;
emitcall(procedureprefix+pstringdef(node^.resulttype)^.stringtypname,true);
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;
disposetree(node); disposetree(node);
p^.left := nil; p^.left := nil;
@ -788,8 +788,8 @@ implementation
popusedregisters(pushed); popusedregisters(pushed);
{save the function result in the destination variable} {save the function result in the destination variable}
Case dest_para^.left^.resulttype^.deftype of Case dest_para^.left^.resulttype^.deftype of
floatdef: floatstore(PFloatDef(dest_para^.left^.resulttype)^.typ, floatdef:
dest_para^.left^.location.reference); floatstore(PFloatDef(dest_para^.left^.resulttype)^.typ,dest_para^.left^.location.reference);
orddef: orddef:
Case PordDef(dest_para^.left^.resulttype)^.typ of Case PordDef(dest_para^.left^.resulttype)^.typ of
u8bit,s8bit: u8bit,s8bit:
@ -1278,7 +1278,10 @@ implementation
end. end.
{ {
$Log$ $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 * all formaldefs are now a sinlge definition
cformaldef (this was necessary for double_checksum) cformaldef (this was necessary for double_checksum)
+ small part of double_checksum code + small part of double_checksum code

15
compiler/symdef.inc
View File

@ -525,6 +525,16 @@
end; 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; function tstringdef.size : longint;
begin begin
size:=savesize; size:=savesize;
@ -3423,7 +3433,10 @@ Const local_symtable_index : longint = $8001;
{ {
$Log$ $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 + double_checksum code added
Revision 1.98 1999/03/06 17:24:16 peter Revision 1.98 1999/03/06 17:24:16 peter

6
compiler/symdefh.inc
View File

@ -444,6 +444,7 @@
constructor ansiload; constructor ansiload;
constructor wideinit(l : longint); constructor wideinit(l : longint);
constructor wideload; constructor wideload;
function stringtypname:string;
function size : longint;virtual; function size : longint;virtual;
procedure write;virtual; procedure write;virtual;
{$ifdef GDB} {$ifdef GDB}
@ -505,7 +506,10 @@
{ {
$Log$ $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 * fixed overloading of array of char
Revision 1.17 1999/03/01 13:45:06 pierre Revision 1.17 1999/03/01 13:45:06 pierre

13
rtl/inc/astrings.inc
View File

@ -490,7 +490,7 @@ end;
{$IfDef ValInternCompiled} {$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; Var SS : String;
begin begin
AnsiStr_To_ShortStr(SS,Pointer(S)); AnsiStr_To_ShortStr(SS,Pointer(S));
@ -498,7 +498,7 @@ begin
end; 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; Var SS : ShortString;
begin begin
@ -507,7 +507,7 @@ begin
end; 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; Var SS : ShortString;
@ -517,7 +517,7 @@ begin
end; end;
{$IfDef SUPPORT_FIXED} {$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; Var SS : String;
begin begin
AnsiStr_To_ShortStr (SS,Pointer(S)); AnsiStr_To_ShortStr (SS,Pointer(S));
@ -764,7 +764,10 @@ end;
{ {
$Log$ $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 * fixed concat when s1 or s2 was nil
Revision 1.17 1999/04/06 11:23:58 peter Revision 1.17 1999/04/06 11:23:58 peter

38
rtl/inc/sstrings.inc
View File

@ -344,12 +344,7 @@ end;
Val() Functions Val() Functions
*****************************************************************************} *****************************************************************************}
Function InitVal(const s:shortstring;var negativ:boolean;var base:byte): Function InitVal(const s:shortstring;var negativ:boolean;var base:byte):ValSInt;
{$IfDef ValInternCompiled}
TMaxSInt;
{$Else ValInternCompiled}
Word;
{$EndIf ValInternCompiled}
var var
Code : Longint; Code : Longint;
begin begin
@ -394,12 +389,12 @@ end;
{$IfDef ValInternCompiled} {$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 var
u: TMaxSInt; u: ValSInt;
base : byte; base : byte;
negative : boolean; negative : boolean;
temp, prev: TMaxUInt; temp, prev: ValUInt;
begin begin
ValSignedInt := 0; ValSignedInt := 0;
Temp:=0; Temp:=0;
@ -423,9 +418,9 @@ begin
u:=16; u:=16;
end; end;
Prev := Temp; Prev := Temp;
Temp := Temp*TMaxUInt(base); Temp := Temp*ValUInt(base);
If ((base = 10) and If ((base = 10) and
(prev > MaxSIntValue div TMaxUInt(Base))) or (prev > MaxSIntValue div ValUInt(Base))) or
(Temp < prev) Then (Temp < prev) Then
Begin Begin
ValSignedInt := 0; ValSignedInt := 0;
@ -444,7 +439,7 @@ begin
inc(code); inc(code);
end; end;
code := 0; code := 0;
ValSignedInt := TMaxSInt(Temp); ValSignedInt := ValSInt(Temp);
If Negative Then If Negative Then
ValSignedInt := -ValSignedInt; ValSignedInt := -ValSignedInt;
If Not(Negative) and (base <> 10) Then If Not(Negative) and (base <> 10) Then
@ -460,12 +455,12 @@ begin
End; End;
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 var
u: TMaxUInt; u: ValUInt;
base : byte; base : byte;
negative : boolean; negative : boolean;
prev: TMaxUInt; prev: ValUInt;
begin begin
ValUnSignedInt:=0; ValUnSignedInt:=0;
Code:=InitVal(s,negative,base); Code:=InitVal(s,negative,base);
@ -481,10 +476,10 @@ begin
u:=16; u:=16;
end; end;
prev := ValUnsignedInt; prev := ValUnsignedInt;
ValUnsignedInt:=ValUnsignedInt*TMaxUInt(base); ValUnsignedInt:=ValUnsignedInt*ValUInt(base);
If prev > ValUnsignedInt Then If prev > ValUnsignedInt Then
{we've had an overflow. Can't check this with {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)} because this division always overflows! (JM)}
Begin Begin
ValUnsignedInt := 0; ValUnsignedInt := 0;
@ -501,7 +496,7 @@ begin
code := 0; code := 0;
end; 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 var
hd, hd,
esign,sign : valreal; esign,sign : valreal;
@ -595,7 +590,7 @@ begin
end; end;
{$ifdef SUPPORT_FIXED} {$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 begin
ValFixed := Fixed(ValFloat(s,code)); ValFixed := Fixed(ValFloat(s,code));
end; end;
@ -1195,7 +1190,10 @@ end;
{ {
$Log$ $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. + Fixed insert with char. length byte wrapped around in some cases.
Revision 1.25 1999/04/01 22:11:50 peter Revision 1.25 1999/04/01 22:11:50 peter

30
rtl/inc/systemh.inc
View File

@ -47,32 +47,27 @@ Type
{ at least declare Turbo Pascal real types } { at least declare Turbo Pascal real types }
{$ifdef i386} {$ifdef i386}
Double = real;
StrLenInt = LongInt; StrLenInt = LongInt;
{$define DEFAULT_EXTENDED} {$define DEFAULT_EXTENDED}
{$define SUPPORT_EXTENDED} {$define SUPPORT_EXTENDED}
{$define SUPPORT_COMP} {$define SUPPORT_COMP}
{$define SUPPORT_SINGLE} {$define SUPPORT_SINGLE}
{causes internalerror(17) with internal val handling, and is not yet fully
{causes internalerror(17) with internal val handling, and is not yet fully
supported anyway (JM)} supported anyway (JM)}
{ define SUPPORT_FIXED} { define SUPPORT_FIXED}
Double = real; ValSInt = Longint;
{$IfDef ValInternCompiled} ValUInt = Cardinal;
TMaxSInt = Longint;
TMaxUInt = Cardinal;
{$EndIf ValInternCompiled}
{$ifdef DEFAULT_EXTENDED}
ValReal = Extended; ValReal = Extended;
{$else}
ValReal = Double;
{$endif}
{$endif} {$endif}
{$ifdef m68k} {$ifdef m68k}
TMaxSInt = Longint;
TMaxUInt = Cardinal;
StrLenInt = Longint; StrLenInt = Longint;
ValSInt = Longint;
ValUInt = Cardinal;
ValReal = Real; ValReal = Real;
{$endif} {$endif}
@ -90,8 +85,8 @@ Type
const const
{$IfDef ValInternCompiled} {$IfDef ValInternCompiled}
{ Maximum value of the biggest signed and unsigned integer type available} { Maximum value of the biggest signed and unsigned integer type available}
MaxSIntValue = High(TMaxSInt); MaxSIntValue = High(ValSInt);
MaxUIntValue = High(TMaxUInt); MaxUIntValue = High(ValUInt);
{$EndIf ValInternCompiled} {$EndIf ValInternCompiled}
@ -457,7 +452,10 @@ const
{ {
$Log$ $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) * 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 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, * 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; 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 Begin
If (InOutRes<>0) then If (InOutRes<>0) then
exit; exit;
@ -486,7 +486,7 @@ Begin
End; 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 Writes a AnsiString to the Text file T
} }
@ -497,7 +497,7 @@ begin
end; 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 var
s : String; s : String;
Begin Begin
@ -508,6 +508,18 @@ Begin
End; 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']; Procedure Write_Real(fixkomma,Len : Longint;var t : TextRec;r : real);[Public,Alias:'FPC_WRITE_TEXT_REAL'];
var var
s : String; s : String;
@ -523,17 +535,6 @@ Begin
End; 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} {$ifdef SUPPORT_SINGLE}
Procedure Write_Single(fixkomma,Len : Longint;var t : TextRec;r : single);[Public,Alias:'FPC_WRITE_TEXT_SINGLE']; Procedure Write_Single(fixkomma,Len : Longint;var t : TextRec;r : single);[Public,Alias:'FPC_WRITE_TEXT_SINGLE'];
var var
@ -732,7 +733,7 @@ Begin
End; 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 var
maxlen, maxlen,
sPos,len : Longint; sPos,len : Longint;
@ -788,32 +789,6 @@ Begin
End; 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']; Procedure Read_PChar(var f : TextRec;var s : PChar);[Public,Alias:'FPC_READ_TEXT_PCHAR_AS_POINTER'];
var var
p,maxp,startp,sidx : PChar; p,maxp,startp,sidx : PChar;
@ -851,7 +826,7 @@ Begin
Move(startp^,sidx^,Len); Move(startp^,sidx^,Len);
inc(sidx,len); inc(sidx,len);
{ was it a LF? then leave } { was it a LF? then leave }
if p^=#10 then if (p<maxp) and (p^=#10) then
begin begin
If pchar(p-1)^=#13 Then If pchar(p-1)^=#13 Then
dec(p); dec(p);
@ -899,7 +874,7 @@ Begin
Move(startp^,sidx^,Len); Move(startp^,sidx^,Len);
inc(sidx,len); inc(sidx,len);
{ was it a LF? then leave } { was it a LF? then leave }
if p^=#10 then if (p<maxp) and (p^=#10) then
begin begin
If pchar(p-1)^=#13 Then If pchar(p-1)^=#13 Then
dec(p); dec(p);
@ -910,7 +885,7 @@ Begin
End; 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 var
p,maxp,startp,sidx : PChar; p,maxp,startp,sidx : PChar;
maxlen,spos,len : longint; maxlen,spos,len : longint;
@ -954,7 +929,7 @@ Begin
inc(sidx,len); inc(sidx,len);
inc(spos,len); inc(spos,len);
{ was it a LF? then leave } { was it a LF? then leave }
if p^=#10 then if (p<maxp) and (p^=#10) then
begin begin
If pchar(sidx-1)^=#13 Then If pchar(sidx-1)^=#13 Then
begin begin
@ -972,6 +947,156 @@ Begin
End; 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']; Procedure Read_Longint(var f : TextRec;var l : Longint);[Public,Alias:'FPC_READ_TEXT_LONGINT'];
var var
hs : String; hs : String;
@ -1080,7 +1205,7 @@ Begin
ReadNumeric(f,hs,Base); ReadNumeric(f,hs,Base);
val(hs,l,code); val(hs,l,code);
If code<>0 Then If code<>0 Then
InOutRes:=201; InOutRes:=106;
End; End;
@ -1183,6 +1308,8 @@ Begin
End; End;
{$endif SUPPORT_FIXED} {$endif SUPPORT_FIXED}
{$endif}
{***************************************************************************** {*****************************************************************************
Initializing Initializing
@ -1208,7 +1335,10 @@ end;
{ {
$Log$ $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 * fixed bug with readln where it sometime didn't read until eol
Revision 1.42 1999/03/16 17:49:39 jonas Revision 1.42 1999/03/16 17:49:39 jonas