+ read single,fixed

+ val with code:longint
  + val for fixed

rtl/inc/sstrings.inc

@@ -19,7 +19,6 @@
 {$I real2str.inc}
 
 function copy(const s : string;index : StrLenInt;count : StrLenInt): string;
-
 begin
   if count<0 then
    count:=0;
@@ -36,12 +35,12 @@ begin
   Move(s[Index+1],Copy[1],Count);
 end;
 
-procedure delete(var s : string;index : StrLenInt;count : StrLenInt);
 
+procedure delete(var s : string;index : StrLenInt;count : StrLenInt);
 begin
   if index<=0 then
    begin
-    count:=count+index-1;
+     inc(count,index-1);
      index:=1;
    end;
   if (Index<=Length(s)) and (Count>0) then
@@ -54,8 +53,8 @@ begin
    end;
 end;
 
-procedure insert(const source : string;var s : string;index : StrLenInt);
 
+procedure insert(const source : string;var s : string;index : StrLenInt);
 begin
   if index>1 then
    dec(index)
@@ -64,11 +63,11 @@ begin
   s:=Copy(s,1,Index)+source+Copy(s,Index+1,length(s));
 end;
 
+
 function pos(const substr : string;const s : string): byte;
-
+var
-var i,j : longint;
+  i,j : longint;
   e   : boolean;
-
 begin
   i := 0;
   j := 0;
@@ -85,12 +84,11 @@ begin
   Pos:=j;
 end;
 
+
 {Faster when looking for a single char...}
-
 function pos(c:char;const s:string):byte;
-
+var
-var i:longint;
+  i : longint;
-
 begin
   for i:=1 to length(s) do
    if s[i]=c then
@@ -101,6 +99,7 @@ begin
   pos:=0;
 end;
 
+
 {$ifdef IBM_CHAR_SET}
 const
   UpCaseTbl : string[7]=#154#142#153#144#128#143#165;
@@ -108,7 +107,6 @@ const
 {$endif}
 
 function upcase(c : char) : char;
-
 {$IFDEF IBM_CHAR_SET}
 var
   i : longint;
@@ -130,16 +128,17 @@ begin
 {$ENDIF}
 end;
 
+
 function upcase(const s : string) : string;
-
+var
-var i : longint;
+  i : longint;
-
 begin
   upcase[0]:=s[0];
   for i := 1 to length (s) do
     upcase[i] := upcase (s[i]);
 end;
 
+
 {$ifndef RTLLITE}
 
 function lowercase(c : char) : char;
@@ -164,18 +163,18 @@ begin
  {$ENDIF}
 end;
 
+
 function lowercase(const s : string) : string;
-
+var
-var i : longint;
+  i : longint;
-
 begin
   lowercase [0]:=s[0];
   for i:=1 to length(s) do
    lowercase[i]:=lowercase (s[i]);
 end;
 
-function hexstr(val : longint;cnt : byte) : string;
 
+function hexstr(val : longint;cnt : byte) : string;
 const
   HexTbl : array[0..15] of char='0123456789ABCDEF';
 var
@@ -190,9 +189,7 @@ begin
 end;
 
 
-
 function binstr(val : longint;cnt : byte) : string;
-
 var
   i : longint;
 begin
@@ -206,13 +203,14 @@ end;
 
 {$endif RTLLITE}
 
- function space (b : byte): string;
 
+function space (b : byte): string;
 begin
   space[0] := chr(b);
   FillChar (Space[1],b,' ');
 end;
 
+
 {*****************************************************************************
                               Str() Helpers
 *****************************************************************************}
@@ -226,6 +224,7 @@ begin
 {$endif}
 end;
 
+
 {$ifdef SUPPORT_SINGLE}
 procedure int_str_single(d : single;len,fr : longint;var s : string);[public, alias : {$ifdef FPCNAMES}'FPC_STR_SINGLE'{$else}'STR_SINGLE'{$endif}];
 begin
@@ -360,7 +359,16 @@ end;
 
 procedure val(const s : string;var l : longint;var code : integer);
 begin
-  val(s,l,word(code));
+  val(s,l,integer(code));
+end;
+
+
+procedure val(const s : string;var l : longint;var code : longint);
+var
+  cw : word;
+begin
+  val (s,l,cw);
+  code:=cw;
 end;
 
 
@@ -396,6 +404,15 @@ begin
 end;
 
 
+procedure val(const s : string;var b : byte;var code : longint);
+var
+  l : longint;
+begin
+  val(s,l,code);
+  b:=l;
+end;
+
+
 procedure val(const s : string;var b : shortint);
 var
   l : longint;
@@ -420,6 +437,15 @@ begin
 end;
 
 
+procedure val(const s : string;var b : shortint;var code : longint);
+var
+  l : longint;
+begin
+  val(s,l,code);
+  b:=l;
+end;
+
+
 procedure val(const s : string;var b : word);
 var
   l : longint;
@@ -444,6 +470,15 @@ begin
 end;
 
 
+procedure val(const s : string;var b : word;var code : longint);
+var
+  l : longint;
+begin
+  val(s,l,code);
+  b:=l;
+end;
+
+
 procedure val(const s : string;var b : integer);
 var
   l : longint;
@@ -467,6 +502,71 @@ begin
   val(s,b,word(code));
 end;
 
+
+procedure val(const s : string;var b : integer;var code : longint);
+var
+  l : longint;
+begin
+  val(s,l,code);
+  b:=l;
+end;
+
+
+procedure val(const s : string;var v : cardinal;var code : word);
+var
+  negativ : boolean;
+  base,u  : byte;
+begin
+  v:=0;
+  code:=InitVal(s,negativ,base);
+  if (Code>length(s)) or negativ then
+   exit;
+  while Code<=Length(s) do
+   begin
+     u:=ord(s[code]);
+     case u of
+       48..57 : u:=u-48;
+       65..70 : u:=u-55;
+      97..104 : u:=u-87;
+     else
+      u:=16;
+     end;
+     cardinal(v):=cardinal(v)*cardinal(longint(base));
+     if (u>base) or (cardinal($ffffffff)-cardinal(v)>cardinal(longint(u))) then
+      begin
+        v:=0;
+        exit;
+      end;
+     v:=v+u;
+     inc(code);
+   end;
+  code:=0;
+end;
+
+
+procedure val(const s : string;var v : cardinal);
+var
+  code : word;
+begin
+  val(s,v,code);
+end;
+
+
+procedure val(const s : string;var v : cardinal;var code : integer);
+begin
+  val(s,v,word(code));
+end;
+
+
+procedure val(const s : string;var v : cardinal;var code : longint);
+var
+  cw : word;
+begin
+  val(s,v,cw);
+  code:=cw;
+end;
+
+
 procedure val(const s : string;var d : valreal;var code : word);
 var
   hd,
@@ -566,12 +666,22 @@ begin
   code:=0;
 end;
 
+
 procedure val(const s : string;var d : valreal;var code : integer);
 begin
   val(s,d,word(code));
 end;
 
 
+procedure val(const s : string;var d : valreal;var code : longint);
+var
+  cw : word;
+begin
+  val(s,d,cw);
+  code:=cw;
+end;
+
+
 procedure val(const s : string;var d : valreal);
 var
   code : word;
@@ -599,16 +709,28 @@ begin
 end;
 
 
+procedure val(const s : string;var d : single;var code : longint);
+var
+  cw : word;
+  e  : valreal;
+begin
+  val(s,e,cw);
+  d:=e;
+  code:=cw;
+end;
+
+
 procedure val(const s : string;var d : single);
 var
   code : word;
-  e    : double;
+  e    : valreal;
 begin
   val(s,e,code);
   d:=e;
 end;
 {$endif SUPPORT_SINGLE}
 
+
 {$ifdef DEFAULT_EXTENDED}
 
   { with extended as default the valreal is extended so for real there need
@@ -632,6 +754,17 @@ end;
   end;
 
 
+  procedure val(const s : string;var d : real;var code : longint);
+  var
+    cw : word;
+    e  : valreal;
+  begin
+    val(s,e,cw);
+    d:=e;
+    code:=cw;
+  end;
+
+
   procedure val(const s : string;var d : real);
   var
     code : word;
@@ -663,6 +796,16 @@ end;
     d:=e;
   end;
 
+  procedure val(const s : string;var d : extended;var code : longint);
+  var
+    cw : word;
+    e  : valreal;
+  begin
+    val(s,e,cw);
+    d:=e;
+    code:=cw;
+  end;
+
   procedure val(const s : string;var d : extended);
   var
     code : word;
@@ -696,6 +839,17 @@ begin
 end;
 
 
+procedure val(const s : string;var d : comp;var code : longint);
+var
+  cw : word;
+  e  : valreal;
+begin
+  val(s,e,cw);
+  d:=comp(e);
+  code:=cw;
+end;
+
+
 procedure val(const s : string;var d : comp);
 var
   code : word;
@@ -706,54 +860,56 @@ begin
 end;
 {$endif SUPPORT_COMP}
 
-procedure val(const s : string;var v : cardinal;var code : word);
+
+{$ifdef SUPPORT_FIXED}
+procedure val(const s : string;var d : fixed;var code : word);
 var
-  negativ : boolean;
+  e : valreal;
-  base,u  : byte;
 begin
-  v:=0;
+  val(s,e,code);
-  code:=InitVal(s,negativ,base);
+  d:=fixed(e);
-  if (Code>length(s)) or negativ then
-   exit;
-  while Code<=Length(s) do
-   begin
-     u:=ord(s[code]);
-     case u of
-       48..57 : u:=u-48;
-       65..70 : u:=u-55;
-      97..104 : u:=u-87;
-     else
-      u:=16;
-     end;
-     cardinal(v):=cardinal(v)*cardinal(longint(base));
-     if (u>base) or (cardinal($ffffffff)-cardinal(v)>cardinal(longint(u))) then
-      begin
-        v:=0;
-        exit;
-      end;
-     v:=v+u;
-     inc(code);
-   end;
-  code:=0;
 end;
 
 
-procedure val(const s : string;var v : cardinal);
+procedure val(const s : string;var d : fixed;var code : integer);
+var
+  e : valreal;
+begin
+  val(s,e,word(code));
+  d:=fixed(e);
+end;
+
+
+procedure val(const s : string;var d : fixed;var code : longint);
+var
+  cw : word;
+  e  : valreal;
+begin
+  val(s,e,cw);
+  d:=fixed(e);
+  code:=cw;
+end;
+
+
+procedure val(const s : string;var d : fixed);
 var
   code : word;
+  e    : valreal;
 begin
-  val(s,v,code);
+  val(s,e,code);
+  d:=fixed(e);
 end;
+{$endif SUPPORT_FIXED}
 
 
-procedure val(const s : string;var v : cardinal;var code : integer);
-begin
-  val(s,v,word(code));
-end;
-
 {
   $Log$
-  Revision 1.12  1998-09-14 10:48:19  peter
+  Revision 1.13  1998-10-10 15:28:46  peter
+    + read single,fixed
+    + val with code:longint
+    + val for fixed
+
+  Revision 1.12  1998/09/14 10:48:19  peter
     * FPC_ names
     * Heap manager is now system independent
 

rtl/inc/systemh.inc

@@ -201,43 +201,60 @@ Function  binStr(Val:Longint;cnt:byte):string;
 Function  Space(b:byte):string;
 Procedure Val(const s:string;Var l:Longint;Var code:Word);
 Procedure Val(const s:string;Var l:Longint;Var code:Integer);
+Procedure Val(const s:string;Var l:Longint;Var code:Longint);
 Procedure Val(const s:string;Var l:Longint);
 Procedure Val(const s:string;Var b:byte;Var code:Word);
 Procedure Val(const s:string;Var b:byte;Var code:Integer);
+Procedure Val(const s:string;Var b:byte;Var code:Longint);
 Procedure Val(const s:string;Var b:byte);
 Procedure Val(const s:string;Var b:shortint;Var code:Word);
 Procedure Val(const s:string;Var b:shortint;Var code:Integer);
+Procedure Val(const s:string;Var b:shortint;Var code:Longint);
 Procedure Val(const s:string;Var b:shortint);
 Procedure Val(const s:string;Var b:Word;Var code:Word);
 Procedure Val(const s:string;Var b:Word;Var code:Integer);
+Procedure Val(const s:string;Var b:Word;Var code:Longint);
 Procedure Val(const s:string;Var b:Word);
 Procedure Val(const s:string;Var b:Integer;Var code:Word);
 Procedure Val(const s:string;Var b:Integer;Var code:Integer);
+Procedure Val(const s:string;Var b:Integer;Var code:Longint);
 Procedure Val(const s:string;Var b:Integer);
 Procedure Val(const s:string;Var v:cardinal;Var code:Word);
 Procedure Val(const s:string;Var v:cardinal;Var code:Integer);
+Procedure Val(const s:string;Var v:cardinal;Var code:Longint);
 Procedure Val(const s:string;Var v:cardinal);
 Procedure Val(const s:string;Var d:ValReal;Var code:Word);
 Procedure Val(const s:string;Var d:ValReal;Var code:Integer);
+Procedure Val(const s:string;Var d:ValReal;Var code:Longint);
 Procedure Val(const s:string;Var d:ValReal);
 {$ifdef SUPPORT_SINGLE}
   Procedure Val(const s:string;Var d:single;Var code:Word);
   Procedure Val(const s:string;Var d:single;Var code:Integer);
+  Procedure Val(const s:string;Var d:single;Var code:Longint);
   Procedure Val(const s:string;Var d:single);
 {$endif SUPPORT_SINGLE}
 {$ifdef SUPPORT_COMP}
   Procedure Val(const s:string;Var d:comp;Var code:Word);
   Procedure Val(const s:string;Var d:comp;Var code:Integer);
+  Procedure Val(const s:string;Var d:comp;Var code:Longint);
   Procedure Val(const s:string;Var d:comp);
 {$endif SUPPORT_COMP}
+{$ifdef SUPPORT_FIXED}
+  Procedure Val(const s:string;Var d:fixed;Var code:Word);
+  Procedure Val(const s:string;Var d:fixed;Var code:Integer);
+  Procedure Val(const s:string;Var d:fixed;Var code:Longint);
+  Procedure Val(const s:string;Var d:fixed);
+{$endif SUPPORT_FIXED}
 {$ifdef DEFAULT_EXTENDED}
   Procedure Val(const s:string;Var d:Real;Var code:Word);
   Procedure Val(const s:string;Var d:Real;Var code:Integer);
+  Procedure Val(const s:string;Var d:Real;Var code:Longint);
   Procedure Val(const s:string;Var d:Real);
 {$else DEFAULT_EXTENDED}
   {$ifdef SUPPORT_EXTENDED}
     Procedure Val(const s:string;Var d:Extended;Var code:Word);
     Procedure Val(const s:string;Var d:Extended;Var code:Integer);
+    Procedure Val(const s:string;Var d:Extended;Var code:Longint);
     Procedure Val(const s:string;Var d:Extended);
   {$endif}
 {$endif DEFAULT_EXTENDED}
@@ -405,7 +422,12 @@ const
 
 {
   $Log$
-  Revision 1.36  1998-10-05 17:22:54  pierre
+  Revision 1.37  1998-10-10 15:28:47  peter
+    + read single,fixed
+    + val with code:longint
+    + val for fixed
+
+  Revision 1.36  1998/10/05 17:22:54  pierre
    * avoid overflow on $8000000 with $Q-
 
   Revision 1.35  1998/10/05 12:32:52  peter

rtl/inc/text.inc

@@ -1075,13 +1075,11 @@ Begin
    HandleError(106);
 End;
 
-
+function ReadRealStr(var f:TextRec):string;
-Procedure Read_Real(var f : TextRec;var d : Real);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_REAL'];
 var
-  hs   : String;
+  hs : string;
-  code : Word;
+begin
-Begin
+  ReadRealStr:='';
-  d:=0.0;
 { Leave if error or not open file, else check for empty buf }
   If (InOutRes<>0) then
    exit;
@@ -1115,53 +1113,38 @@ Begin
          ReadNumeric(f,hs,10);
       end;
    end;
-  val(hs,d,code);
+  ReadRealStr:=hs;
+end;
+
+
+Procedure Read_Real(var f : TextRec;var d : Real);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_REAL'];
+var
+  code : Word;
+Begin
+  val(ReadRealStr(f),d,code);
   If code<>0 Then
    HandleError(106);
 End;
 
 
+{$ifdef SUPPORT_SINGLE}
+Procedure Read_Single(var f : TextRec;var d : single);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_SINGLE'];
+var
+  code : Word;
+Begin
+  val(ReadRealStr(f),d,code);
+  If code<>0 Then
+   HandleError(106);
+End;
+{$endif SUPPORT_SINGLE}
+
+
 {$ifdef SUPPORT_EXTENDED}
 Procedure Read_Extended(var f : TextRec;var d : extended);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_EXTENDED'];
 var
-  hs   : String;
   code : Word;
 Begin
-  d:=0.0;
+  val(ReadRealStr(f),d,code);
-{ 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,d,code);
   If code<>0 Then
    HandleError(106);
 End;
@@ -1171,50 +1154,27 @@ End;
 {$ifdef SUPPORT_COMP}
 Procedure Read_Comp(var f : TextRec;var d : comp);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_COMP'];
 var
-  hs   : String;
   code : Word;
 Begin
-  d:=comp(0.0);
+  val(ReadRealStr(f),d,code);
-{ 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,d,code);
   If code<>0 Then
    HandleError(106);
 End;
 {$endif SUPPORT_COMP}
 
 
+{$ifdef SUPPORT_FIXED}
+Procedure Read_Fixed(var f : TextRec;var d : fixed);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_FIXED'];
+var
+  code : Word;
+Begin
+  val(ReadRealStr(f),d,code);
+  If code<>0 Then
+   HandleError(106);
+End;
+{$endif SUPPORT_FIXED}
+
+
 {*****************************************************************************
                                Initializing
 *****************************************************************************}
@@ -1239,7 +1199,12 @@ end;
 
 {
   $Log$
-  Revision 1.30  1998-09-29 08:39:07  michael
+  Revision 1.31  1998-10-10 15:28:48  peter
+    + read single,fixed
+    + val with code:longint
+    + val for fixed
+
+  Revision 1.30  1998/09/29 08:39:07  michael
   + Ansistring write now gets pointer.
 
   Revision 1.29  1998/09/28 14:27:08  michael