From dda7bf2bc9b113f0a7a890aefc06044bcd7d2d21 Mon Sep 17 00:00:00 2001 From: peter Date: Thu, 8 Apr 1999 15:57:44 +0000 Subject: [PATCH] + subrange checking for readln() --- bugs/bug0185.pp | 4 - bugs/readme.txt | 8 +- compiler/cg386inl.pas | 383 +++++++++++++++++++++--------------------- compiler/symdef.inc | 15 +- compiler/symdefh.inc | 6 +- rtl/inc/astrings.inc | 13 +- rtl/inc/sstrings.inc | 38 ++--- rtl/inc/systemh.inc | 40 +++-- rtl/inc/text.inc | 224 ++++++++++++++++++------ 9 files changed, 438 insertions(+), 293 deletions(-) diff --git a/bugs/bug0185.pp b/bugs/bug0185.pp index 4ce1bf28b2..efda238e7b 100644 --- a/bugs/bug0185.pp +++ b/bugs/bug0185.pp @@ -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. diff --git a/bugs/readme.txt b/bugs/readme.txt index 3737ea483d..41ef126bb1 100644 --- a/bugs/readme.txt +++ b/bugs/readme.txt @@ -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 diff --git a/compiler/cg386inl.pas b/compiler/cg386inl.pas index abd57155e0..7e69082fc1 100644 --- a/compiler/cg386inl.pas +++ b/compiler/cg386inl.pas @@ -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 diff --git a/compiler/symdef.inc b/compiler/symdef.inc index 1710a86254..06fc0ec2b9 100644 --- a/compiler/symdef.inc +++ b/compiler/symdef.inc @@ -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 diff --git a/compiler/symdefh.inc b/compiler/symdefh.inc index d61a4f20c0..68c4d194c6 100644 --- a/compiler/symdefh.inc +++ b/compiler/symdefh.inc @@ -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 diff --git a/rtl/inc/astrings.inc b/rtl/inc/astrings.inc index 20ae3cca35..f34e4e4930 100644 --- a/rtl/inc/astrings.inc +++ b/rtl/inc/astrings.inc @@ -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 diff --git a/rtl/inc/sstrings.inc b/rtl/inc/sstrings.inc index 100b813202..5e669a85fb 100644 --- a/rtl/inc/sstrings.inc +++ b/rtl/inc/sstrings.inc @@ -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 diff --git a/rtl/inc/systemh.inc b/rtl/inc/systemh.inc index 584604e685..b01f665e50 100644 --- a/rtl/inc/systemh.inc +++ b/rtl/inc/systemh.inc @@ -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, diff --git a/rtl/inc/text.inc b/rtl/inc/text.inc index da99b32b26..f3951ebd69 100644 --- a/rtl/inc/text.inc +++ b/rtl/inc/text.inc @@ -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 (p0) 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 + 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 + 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