Merged revisions 7159,7468,7790,7959,8220,8306,8321,8332,8394-8395 via svnmerge from

http://svn.freepascal.org/svn/fpc/trunk

........
r7159 | pierre | 2007-04-23 09:43:51 +0200 (Mon, 23 Apr 2007) | 1 line

 * reject 0x#0 and variations in val function
........
r7468 | micha | 2007-05-25 11:43:36 +0200 (Fri, 25 May 2007) | 1 line

* allow shrinking ansistrings if at least half of its memory is saved
........
r7790 | jonas | 2007-06-24 15:04:44 +0200 (Sun, 24 Jun 2007) | 2 lines

  * removed divisions from val() for unsigned types

........
r7959 | jonas | 2007-07-05 17:25:01 +0200 (Thu, 05 Jul 2007) | 2 lines

  * fixed str(extended(0.005):0:2) and related problems

........
r8220 | jonas | 2007-08-04 19:38:48 +0200 (Sat, 04 Aug 2007) | 2 lines

  * fixed FormatFloat for non-x86 (mantis 9384)

........
r8306 | michael | 2007-08-25 15:41:22 +0200 (Sat, 25 Aug 2007) | 1 line

* Added copy,length and setlength
........
r8321 | jonas | 2007-08-28 21:01:49 +0200 (Tue, 28 Aug 2007) | 2 lines

  * fixed potential range errors

........
r8332 | jonas | 2007-08-29 14:06:54 +0200 (Wed, 29 Aug 2007) | 2 lines

  + added QWord overloads for IntToHex, hexStr, OctStr, binStr

........
r8394 | jonas | 2007-09-07 13:54:00 +0200 (Fri, 07 Sep 2007) | 3 lines

  * removed unused variable from fpc_shortstr_enum and reformatted
    its declarations

........
r8395 | jonas | 2007-09-07 16:06:08 +0200 (Fri, 07 Sep 2007) | 2 lines

  * fixed buffer overflows in int_str() + test

........

git-svn-id: branches/fixes_2_2@8442 -

rtl/inc/astrings.inc

@@ -527,7 +527,7 @@ Procedure fpc_AnsiStr_SetLength (Var S : AnsiString; l : SizeInt);[Public,Alias
 }
 Var
   Temp : Pointer;
-  lens,
+  lens, lena,
   movelen : SizeInt;
 begin
   if (l>0) then
@@ -541,7 +541,10 @@ begin
       else if PAnsiRec(Pointer(S)-FirstOff)^.Ref=1 then
         begin
           Dec(Pointer(S),FirstOff);
-          if AnsiRecLen+L>MemSize(Pointer(s)) then
+          lens:=MemSize(Pointer(s));
+          lena:=AnsiRecLen+L;
+          { allow shrinking string if that saves at least half of current size }
+          if (lena>lens) or ((lens>32) and (lena<=(lens div 2))) then
             reallocmem(pointer(S),AnsiRecLen+L);
           Inc(Pointer(S),FirstOff);
         end

rtl/inc/generic.inc

@@ -1156,16 +1156,21 @@ var
   m,m1 : longword;
   pc,pc2 : pchar;
   hs : string[32];
+  b : longint;
 begin
   pc2:=@s[1];
   if (l<0) then
     begin
+      b:=1;
       pc2^:='-';
       inc(pc2);
       m:=longword(-l);
     end
   else
-    m:=longword(l);
+    begin
+      b:=0;
+      m:=longword(l);
+    end;
   pc:=@hs[0];
   repeat
     inc(pc);
@@ -1173,13 +1178,15 @@ begin
     pc^:=char(m-(m1*10)+byte('0'));
     m:=m1;
   until m=0;
-  while (pc>pchar(@hs[0])) do
+  while (pc>pchar(@hs[0])) and
+        (b<high(s)) do
     begin
       pc2^:=pc^;
       dec(pc);
       inc(pc2);
+      inc(b);
     end;
-  s[0]:=char(pc2-pchar(@s[1]));
+  s[0]:=chr(b);
 end;
 
 {$endif ndef FPC_SYSTEM_HAS_INT_STR_LONGINT}
@@ -1189,6 +1196,7 @@ end;
 procedure int_str(l:longword;out s:string);
 var
   m1 : longword;
+  b: longint;
   pc,pc2 : pchar;
   hs : string[32];
 begin
@@ -1200,13 +1208,16 @@ begin
     pc^:=char(l-(m1*10)+byte('0'));
     l:=m1;
   until l=0;
-  while (pc>pchar(@hs[0])) do
+  b:=0;
+  while (pc>pchar(@hs[0])) and
+        (b<high(s)) do
     begin
       pc2^:=pc^;
       dec(pc);
       inc(pc2);
+      inc(b);
     end;
-  s[0]:=char(pc2-pchar(@s[1]));
+  s[0]:=chr(b);
 end;
 
 {$endif ndef FPC_SYSTEM_HAS_INT_STR_LONGWORD}
@@ -1217,17 +1228,22 @@ procedure int_str(l:int64;out s:string);
 var
   m,m1 : qword;
   pc,pc2 : pchar;
+  b: longint;
   hs : string[64];
 begin
   pc2:=@s[1];
   if (l<0) then
     begin
+      b:=1;
       pc2^:='-';
       inc(pc2);
       m:=qword(-l);
     end
   else
-    m:=qword(l);
+    begin
+      b:=0;
+      m:=qword(l);
+    end;
   pc:=@hs[0];
   repeat
     inc(pc);
@@ -1235,13 +1251,15 @@ begin
     pc^:=char(m-(m1*10)+byte('0'));
     m:=m1;
   until m=0;
-  while (pc>pchar(@hs[0])) do
+  while (pc>pchar(@hs[0])) and
+        (b < high(s)) do
     begin
       pc2^:=pc^;
       dec(pc);
       inc(pc2);
+      inc(b);
     end;
-  s[0]:=char(pc2-pchar(@s[1]));
+  s[0]:=chr(b);
 end;
 
 {$endif ndef FPC_SYSTEM_HAS_INT_STR_INT64}
@@ -1252,6 +1270,7 @@ procedure int_str(l:qword;out s:string);
 var
   m1 : qword;
   pc,pc2 : pchar;
+  b: longint;
   hs : string[64];
 begin
   pc2:=@s[1];
@@ -1262,13 +1281,16 @@ begin
     pc^:=char(l-(m1*10)+byte('0'));
     l:=m1;
   until l=0;
-  while (pc>pchar(@hs[0])) do
+  b:=0;
+  while (pc>pchar(@hs[0])) and
+        (b<high(s)) do
     begin
       pc2^:=pc^;
       dec(pc);
       inc(pc2);
+      inc(b);
     end;
-  s[0]:=char(pc2-pchar(@s[1]));
+  s[0]:=chr(b);
 end;
 
 {$endif ndef FPC_SYSTEM_HAS_INT_STR_QWORD}

rtl/inc/real2str.inc

@@ -378,9 +378,9 @@ begin
           for fracCount := 1 to currPrec do
             factor := factor * 10.0;
           corrval := corrval / factor;
-          if d >= corrVal then
+          if d >= corrVal-roundCorr then
             d := d + corrVal;
-          if int(d) = 1 then
+          if int(d+roundCorr) = 1 then
             begin
               roundStr(temp,spos);
               d := frac(d);

rtl/inc/sstrings.inc

@@ -65,9 +65,9 @@ begin
    index:=length(s)+1;
   indexlen:=Length(s)-Index+1;
   srclen:=length(Source);
-  if SizeInt(length(source)+length(s))>=sizeof(s) then
+  if sizeInt(length(source))+sizeint(length(s))>=sizeof(s) then
    begin
-     cut:=SizeInt(length(source)+length(s))-sizeof(s)+1;
+     cut:=sizeInt(length(source))+sizeint(length(s))-sizeof(s)+1;
      if cut>indexlen then
       begin
         dec(srclen,cut-indexlen);
@@ -91,7 +91,7 @@ begin
   if index>length(s) then
    index:=length(s)+1;
   indexlen:=Length(s)-Index+1;
-  if (length(s)+1=sizeof(s)) and (indexlen>0) then
+  if (sizeint(length(s))+1=sizeof(s)) and (indexlen>0) then
    dec(indexlen);
   move(s[Index],s[Index+1],indexlen);
   s[Index]:=Source;
@@ -107,7 +107,7 @@ begin
   Pos:=0;
   if Length(SubStr)>0 then
    begin
-     MaxLen:=Length(s)-Length(SubStr);
+     MaxLen:=sizeint(Length(s))-Length(SubStr);
      i:=0;
      pc:=@s[1];
      while (i<=MaxLen) do
@@ -314,12 +314,30 @@ begin
 end;
 
 
+Function  hexStr(Val:qword;cnt:byte):shortstring;
+begin
+  hexStr:=hexStr(int64(Val),cnt);
+end;
+
+
+Function  OctStr(Val:qword;cnt:byte):shortstring;
+begin
+  OctStr:=OctStr(int64(Val),cnt);
+end;
+
+
+Function  binStr(Val:qword;cnt:byte):shortstring;
+begin
+  binStr:=binStr(int64(Val),cnt);
+end;
+
+
 function hexstr(val : pointer) : shortstring;
 var
   i : longint;
-  v : ptrint;
+  v : ptruint;
 begin
-  v:=ptrint(val);
+  v:=ptruint(val);
   hexstr[0]:=chr(sizeof(pointer)*2);
   for i:=sizeof(pointer)*2 downto 1 do
    begin
@@ -356,20 +374,20 @@ end;
 
 {$ifndef CPU64}
 
-  procedure fpc_shortstr_qword(v : qword;len : longint;out s : shortstring);[public,alias:'FPC_SHORTSTR_QWORD']; compilerproc;
-    begin
-       int_str(v,s);
-       if length(s)<len then
-         s:=space(len-length(s))+s;
-    end;
+procedure fpc_shortstr_qword(v : qword;len : longint;out s : shortstring);[public,alias:'FPC_SHORTSTR_QWORD']; compilerproc;
+begin
+  int_str(v,s);
+  if length(s)<len then
+    s:=space(len-length(s))+s;
+end;
 
 
-  procedure fpc_shortstr_int64(v : int64;len : longint;out s : shortstring);[public,alias:'FPC_SHORTSTR_INT64'];  compilerproc;
-    begin
-       int_str(v,s);
-       if length(s)<len then
-         s:=space(len-length(s))+s;
-    end;
+procedure fpc_shortstr_int64(v : int64;len : longint;out s : shortstring);[public,alias:'FPC_SHORTSTR_INT64'];  compilerproc;
+begin
+  int_str(v,s);
+  if length(s)<len then
+    s:=space(len-length(s))+s;
+end;
 
 {$endif CPU64}
 
@@ -380,12 +398,13 @@ end;
 
 {$I real2str.inc}
 
-procedure fpc_ShortStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_FLOAT']; compilerproc;
+procedure fpc_shortstr_float(d : ValReal;len,fr,rt : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_FLOAT']; compilerproc;
 begin
   str_real(len,fr,d,treal_type(rt),s);
 end;
 
-procedure fpc_ShortStr_Currency(c : currency; len,f : SizeInt; out s : shortstring);[public,alias:'FPC_SHORTSTR_CURRENCY']; compilerproc;
+
+procedure fpc_shortstr_currency(c : currency; len,f : SizeInt; out s : shortstring);[public,alias:'FPC_SHORTSTR_CURRENCY']; compilerproc;
 const
   MinLen = 8; { Minimal string length in scientific format }
 
@@ -678,14 +697,14 @@ begin
             end;
       '%' : begin
               base:=2;
-              inc(code);              
+              inc(code);
             end;
       '&' : begin
               Base:=8;
-              inc(code);              
+              inc(code);
             end;
       '0' : begin
-              if (code < length(s)) and (s[code+1] in ['x', 'X']) then 
+              if (code < length(s)) and (s[code+1] in ['x', 'X']) then
               begin
                 inc(code, 2);
                 base := 16;
@@ -703,8 +722,8 @@ end;
 
 Function fpc_Val_SInt_ShortStr(DestSize: SizeInt; Const S: ShortString; out Code: ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_SHORTSTR']; compilerproc;
 var
-  u, temp, prev, maxPrevValue, maxNewValue: ValUInt;
-  base : byte;
+  temp, prev, maxPrevValue, maxNewValue: ValUInt;
+  base,u : byte;
   negative : boolean;
 begin
   fpc_Val_SInt_ShortStr := 0;
@@ -712,6 +731,12 @@ begin
   Code:=InitVal(s,negative,base);
   if Code>length(s) then
    exit;
+  if (s[Code]=#0) then
+    begin
+      if (Code>1) and (s[Code-1]='0') then
+        Code:=0;
+      exit;
+    end;
   maxPrevValue := ValUInt(MaxUIntValue) div ValUInt(Base);
   if (base = 10) then
     maxNewValue := MaxSIntValue + ord(negative)
@@ -761,14 +786,20 @@ Function int_Val_SInt_ShortStr(DestSize: SizeInt; Const S: ShortString; out Code
 
 Function fpc_Val_UInt_Shortstr(Const S: ShortString; out Code: ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_SHORTSTR']; compilerproc;
 var
-  u, prev : ValUInt;
-  base : byte;
+  prev : ValUInt;
+  base,u : byte;
   negative : boolean;
 begin
   fpc_Val_UInt_Shortstr:=0;
   Code:=InitVal(s,negative,base);
   If Negative or (Code>length(s)) Then
     Exit;
+  if (s[Code]=#0) then
+    begin
+      if (Code>1) and (s[Code-1]='0') then
+        Code:=0;
+      exit;
+    end;
   while Code<=Length(s) do
    begin
      case s[Code] of
@@ -780,13 +811,13 @@ begin
       u:=16;
      end;
      prev := fpc_Val_UInt_Shortstr;
+     fpc_Val_UInt_Shortstr:=fpc_Val_UInt_Shortstr*ValUInt(base) + u;
      If (u>=base) or
-        (ValUInt(MaxUIntValue-u) div ValUInt(Base)<prev) then
+        (prev>fpc_Val_UInt_Shortstr) then
       begin
         fpc_Val_UInt_Shortstr:=0;
         exit;
       end;
-     fpc_Val_UInt_Shortstr:=fpc_Val_UInt_Shortstr*ValUInt(base) + u;
      inc(code);
    end;
   code := 0;
@@ -810,6 +841,12 @@ end;
     Code:=InitVal(s,negative,base);
     if Code>length(s) then
      exit;
+    if (s[Code]=#0) then
+      begin
+        if (Code>1) and (s[Code-1]='0') then
+          Code:=0;
+        exit;
+      end;
     maxprevvalue := maxqword div base;
     if (base = 10) then
       maxnewvalue := maxint64 + ord(negative)
@@ -846,22 +883,23 @@ end;
 
 
   Function fpc_val_qword_shortstr(Const S: ShortString; out Code: ValSInt): QWord; [public, alias:'FPC_VAL_QWORD_SHORTSTR']; compilerproc;
-    type qwordrec = packed record
-      l1,l2: longint;
-    end;
-    var
-       u, prev, maxqword: QWord;
+
+  var  u, prev: QWord;
        base : byte;
        negative : boolean;
+
+  const maxqword=qword($ffffffffffffffff);
+
   begin
     fpc_val_qword_shortstr:=0;
     Code:=InitVal(s,negative,base);
     If Negative or (Code>length(s)) Then
       Exit;
-    with qwordrec(maxqword) do
+    if (s[Code]=#0) then
       begin
-        l1 := longint($ffffffff);
-        l2 := longint($ffffffff);
+        if (Code>1) and (s[Code-1]='0') then
+          Code:=0;
+        exit;
       end;
     while Code<=Length(s) do
      begin
@@ -874,13 +912,13 @@ end;
         u:=16;
        end;
        prev := fpc_val_qword_shortstr;
+       fpc_val_qword_shortstr:=fpc_val_qword_shortstr*QWord(base) + u;
        If (u>=base) or
-         ((QWord(maxqword-u) div QWord(base))<prev) then
+          (prev>fpc_val_qword_shortstr) then
          Begin
            fpc_val_qword_shortstr := 0;
            Exit
          End;
-       fpc_val_qword_shortstr:=fpc_val_qword_shortstr*QWord(base) + u;
        inc(code);
      end;
     code := 0;
@@ -1018,7 +1056,7 @@ begin
 end;
 
 
-Function fpc_Val_Currency_ShortStr(const s : shortstring; out Code : ValSInt): currency; [public, alias:'FPC_VAL_CURRENCY_SHORTSTR']; compilerproc;
+function fpc_Val_Currency_ShortStr(const s : shortstring; out Code : ValSInt): currency; [public, alias:'FPC_VAL_CURRENCY_SHORTSTR']; compilerproc;
 const
   MaxInt64 : Int64  = $7FFFFFFFFFFFFFFF;
   Int64Edge : Int64 = ($7FFFFFFFFFFFFFFF - 10) div 10;

rtl/inc/system.fpd

@@ -51,3 +51,9 @@ Procedure Write (Args : Arguments);
 Procedure Writeln (Args : Arguments);
 Procedure Write (Var F : Text; Args : Arguments);
 Procedure WriteLn (Var F : Text; Args : Arguments);
+Function Copy(S : AStringType; Index,Count : Integer) : String;
+Function Copy(A : DynArrayType; Index,Count : Integer) : DynArray;
+Procedure SetLength(Var S : AStringType; Len : Integer);
+Procedure SetLength(Var A : DynArrayType; Len : Integer);
+Function Length(S : AStringType) : Integer;
+Function Length(A : DynArrayType) : Integer;

rtl/inc/systemh.inc

@@ -555,6 +555,9 @@ Function  binStr(Val:Longint;cnt:byte):shortstring;
 Function  hexStr(Val:int64;cnt:byte):shortstring;
 Function  OctStr(Val:int64;cnt:byte):shortstring;
 Function  binStr(Val:int64;cnt:byte):shortstring;
+Function  hexStr(Val:qword;cnt:byte):shortstring;
+Function  OctStr(Val:qword;cnt:byte):shortstring;
+Function  binStr(Val:qword;cnt:byte):shortstring;
 Function  hexStr(Val:Pointer):shortstring;
 
 { Char functions }

rtl/objpas/sysutils/sysformt.inc

@@ -318,7 +318,7 @@ begin
                    index:=31;
                  end;
               If Prec>index then
-                ToAdd:=HexStr(vq,index)
+                ToAdd:=HexStr(int64(vq),index)
               else
                 begin
                 // determine minimum needed number of hex digits.
@@ -327,7 +327,7 @@ begin
                   inc(Index);
                 If Index>Prec then
                   Prec:=Index;
-                ToAdd:=HexStr(vq,Prec);
+                ToAdd:=HexStr(int64(vq),Prec);
                 end;
               end;
         '%': ToAdd:='%';

rtl/objpas/sysutils/sysstr.inc

@@ -752,6 +752,10 @@ begin
  end;
 end ;
 
+function IntToHex(Value: QWord; Digits: integer): string;
+begin
+  result:=IntToHex(Int64(Value),Digits);
+end;
 
 function TryStrToInt(const s: string; var i : integer) : boolean;
 var Error : word;
@@ -1970,11 +1974,13 @@ Var
       Str(Value:Width+8,Digits);
       { Find and cut out exponent. Always the
         last 6 characters in the string.
-        -> 0000E+0000                         }
-      I:=Length(Digits)-5;
-      Val(Copy(Digits,I+1,5),Exp,J);
+        -> 0000E+0000                         
+        *** No, not always the last 6 characters, this depends on
+            the maximally supported precision (JM)}
+      I:=Pos('E',Digits);
+      Val(Copy(Digits,I+1,255),Exp,J);
       Exp:=Exp+1-(Placehold[1]+Placehold[2]);
-      Delete(Digits, I, 6);
+      Delete(Digits, I, 255);
       { Str() always returns at least one digit after the decimal point.
         If we don't want it, we have to remove it. }
       If (Decimals=0) And (Placehold[1]+Placehold[2]<= 1) Then

rtl/objpas/sysutils/sysstrh.inc

@@ -107,6 +107,7 @@ function IntToStr(Value: Int64): string;
 function IntToStr(Value: QWord): string;
 function IntToHex(Value: integer; Digits: integer): string;
 function IntToHex(Value: Int64; Digits: integer): string;
+function IntToHex(Value: QWord; Digits: integer): string;
 function StrToInt(const s: string): integer;
 function TryStrToInt(const s: string; var i : integer) : boolean;
 function StrToInt64(const s: string): int64;

tests/test/tstrreal3.pp

@@ -45,6 +45,12 @@ begin
  writeln(result);
  if (result <> '8.502') then
    halt(1);
+
+ e:=0.005;
+ str(e:0:2,result);
+ writeln(result);
+ if (result<>'0.01') then
+   halt(1);
 end;
 
 begin