+ subrange checking for readln()

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.

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

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,43 +732,29 @@ implementation
                emitpushreferenceaddr(exprasmlist,hr);
              End;
 
+          {node = first parameter = string}
+           dummycoll.paratyp:=vs_const;
+           dummycoll.data:=node^.resulttype;
+           secondcallparan(node,@dummycoll,false,false,0);
+           if codegenerror then
+             exit;
+
            Case dest_para^.resulttype^.deftype of
              floatdef:
                procedureprefix := 'FPC_VAL_REAL_';
              orddef:
                if is_signed(dest_para^.resulttype) then
-                 procedureprefix := 'FPC_VAL_SINT_'
+                 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;
-
-          {node = first parameter = string}
-           dummycoll.paratyp:=vs_const;
-           dummycoll.data:=node^.resulttype;
-           secondcallparan(node,@dummycoll,false,false,0);
-           if codegenerror then
-             exit;
-
-           {if we are converting to a signed number, we have to include the
-            size of the destination, so the Val function can extend the sign
-            of the result to allow proper range checking}
-           If (dest_para^.resulttype^.deftype = orddef) Then
-              Case PordDef(dest_para^.resulttype)^.typ of
-                s8bit: exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_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;
+           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

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

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

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

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

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,

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