development/compilers/freepascal/rtl/inc/real2str.inc

   1 {
   2     $Id$
   3     This file is part of the Free Pascal run time library.
   4     Copyright (c) 1999-2000 by Michael Van Canneyt,
   5     member of the Free Pascal development team
   6
   7     See the file COPYING.FPC, included in this distribution,
   8     for details about the copyright.
   9
  10     This program is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  13
  14  **********************************************************************}
  15
  16 type
  17   { See symdefh.inc tfloattyp }
  18   treal_type = (rt_s32real,rt_s64real,rt_s80real,rt_c64bit,rt_f16bit,rt_f32bit);
  19   { corresponding to single   double   extended   fixed      comp for i386 }
  20
  21 Procedure str_real (len,f : longint; d : ValReal; real_type :treal_type; var s : string);
  22 {$ifdef SUPPORT_EXTENDED}
  23 type
  24   TSplitExtended = packed record
  25     case byte of
  26       0: (bytes: Array[0..9] of byte);
  27       1: (words: Array[0..4] of word);
  28       2: (cards: Array[0..1] of cardinal; w: word);
  29   end;
  30 const
  31   maxDigits = 17;
  32 {$else}
  33 {$ifdef SUPPORT_DOUBLE}
  34 type
  35   TSplitDouble = packed record
  36     case byte of
  37       0: (bytes: Array[0..7] of byte);
  38       1: (words: Array[0..3] of word);
  39       2: (cards: Array[0..1] of cardinal);
  40   end;
  41 const
  42   maxDigits = 14;
  43 {$else}
  44 {$ifdef SUPPORT_SINGLE}
  45 type
  46   TSplitSingle = packed record
  47     case byte of
  48       0: (bytes: Array[0..3] of byte);
  49       1: (words: Array[0..1] of word);
  50       2: (cards: Array[0..0] of cardinal);
  51   end;
  52 const
  53   maxDigits = 9;
  54 {$endif SUPPORT_SINGLE}
  55 {$endif SUPPORT_DOUBLE}
  56 {$endif SUPPORT_EXTENDED}
  57
  58 type
  59   { the value in the last position is used for rounding }
  60   TIntPartStack = array[1..maxDigits+1] of valReal;
  61
  62 var
  63   roundCorr, corrVal: valReal;
  64   intPart, spos, endpos, fracCount: longint;
  65   correct, currprec: longint;
  66   temp : string;
  67   power : string[10];
  68   sign : boolean;
  69   dot : byte;
  70   mantZero, expMaximal: boolean;
  71
  72   procedure RoundStr(var s: string; lastPos: byte);
  73   var carry: longint;
  74   begin
  75     carry := 1;
  76     repeat
  77       s[lastPos] := chr(ord(s[lastPos])+carry);
  78       carry := 0;
  79       if s[lastPos] > '9' then
  80         begin
  81           s[lastPos] := '0';
  82           carry := 1;
  83         end;
  84       dec(lastPos);
  85     until carry = 0;
  86   end;
  87
  88   procedure getIntPart(d: extended);
  89   var
  90     intPartStack: TIntPartStack;
  91     stackPtr, endStackPtr, digits: longint;
  92     overflow: boolean;
  93   begin
  94     { position in the stack (gets increased before first write) }
  95     stackPtr := 0;
  96     { number of digits processed }
  97     digits := 0;
  98     { did we wrap around in the stack? Necessary to know whether we should round }
  99     overflow :=false;
 100     { generate a list consisting of d, d/10, d/100, ... until d < 1.0 }
 101     while d > 1.0-roundCorr do
 102       begin
 103         inc(stackPtr);
 104         inc(digits);
 105         if stackPtr > maxDigits+1 then
 106           begin
 107             stackPtr := 1;
 108             overflow := true;
 109           end;
 110         intPartStack[stackPtr] := d;
 111         d := d / 10.0;
 112       end;
 113     { if no integer part, exit }
 114     if digits = 0 then
 115       exit;
 116     endStackPtr := stackPtr+1;
 117     if endStackPtr > maxDigits + 1 then
 118       endStackPtr := 1;
 119  { now, all digits are calculated using trunc(d*10^(-n)-int(d*10^(-n-1))*10) }
 120     corrVal := 0.0;
 121  { the power of 10 with which the resulting string has to be "multiplied" }
 122  { if the decimal point is placed after the first significant digit       }
 123     correct := digits-1;
 124     repeat
 125       if (currprec > 0) then
 126         begin
 127           intPart:= trunc(intPartStack[stackPtr]-corrVal);
 128           dec(currPrec);
 129           inc(spos);
 130           temp[spos] := chr(intPart+ord('0'));
 131           if temp[spos] > '9' then
 132             begin
 133               temp[spos] := chr(ord(temp[spos])-10);
 134               roundStr(temp,spos-1);
 135             end;
 136         end;
 137       corrVal := int(intPartStack[stackPtr]) * 10.0;
 138       dec(stackPtr);
 139       if stackPtr = 0 then
 140         stackPtr := maxDigits+1;
 141     until (overflow and (stackPtr = endStackPtr)) or
 142           (not overflow and (stackPtr = maxDigits+1)) or (currPrec = 0);
 143     { round if we didn't use all available digits yet and if the }
 144     { remainder is > 5                                           }
 145     if overflow  and
 146        (trunc(intPartStack[stackPtr]-corrVal) > 5.0 - roundCorr) then
 147       roundStr(temp,spos);
 148   end;
 149
 150 var  maxlen : longint;   { Maximal length of string for float }
 151      minlen : longint;   { Minimal length of string for float }
 152      explen : longint;   { Length of exponent, including E and sign.
 153                            Must be strictly larger than 2 }
 154 const
 155       maxexp = 1e+35;   { Maximum value for decimal expressions }
 156       minexp = 1e-35;   { Minimum value for decimal expressions }
 157       zero   = '0000000000000000000000000000000000000000';
 158
 159 begin
 160   case real_type of
 161     rt_s32real :
 162       begin
 163          maxlen:=16;
 164          minlen:=8;
 165          explen:=4;
 166          { correction used with comparing to avoid rounding/precision errors }
 167          roundCorr := (1/exp((16-4-3)*ln(10)));
 168       end;
 169     rt_s64real :
 170       begin
 171 { if the maximum suppported type is double, we can print out one digit }
 172 { less, because otherwise we can't round properly and 1e-400 becomes   }
 173 { 0.99999999999e-400 (JM)                                              }
 174 {$ifdef support_extended}
 175          maxlen:=23;
 176          { correction used with comparing to avoid rounding/precision errors }
 177          roundCorr := (1/exp((23-5-3)*ln(10)));
 178 {$else support_extended}
 179 {$ifdef support_double}
 180          maxlen := 22;
 181          { correction used with comparing to avoid rounding/precision errors }
 182          roundCorr := (1/exp((22-4-3)*ln(10)));
 183 {$endif support_double}
 184 {$endif support_extended}
 185          minlen:=9;
 186          explen:=5;
 187       end;
 188     rt_s80real :
 189       begin
 190          { Different in TP help, but this way the output is the same (JM) }
 191          maxlen:=25;
 192          minlen:=10;
 193          explen:=6;
 194          { correction used with comparing to avoid rounding/precision errors }
 195          roundCorr := (1/exp((25-6-3)*ln(10)));
 196       end;
 197     rt_c64bit  :
 198       begin
 199          maxlen:=23;
 200          minlen:=10;
 201          { according to TP (was 5) (FK) }
 202          explen:=6;
 203          { correction used with comparing to avoid rounding/precision errors }
 204          roundCorr := (1/exp((23-6-3)*ln(10)));
 205       end;
 206     rt_f16bit  :
 207       begin
 208          maxlen:=16;
 209          minlen:=8;
 210          explen:=4;
 211          { correction used with comparing to avoid rounding/precision errors }
 212          roundCorr := (1/exp((16-4-3)*ln(10)));
 213       end;
 214     rt_f32bit  :
 215       begin
 216          maxlen:=16;
 217          minlen:=8;
 218          explen:=4;
 219          { correction used with comparing to avoid rounding/precision errors }
 220          roundCorr := (1/exp((16-4-3)*ln(10)));
 221       end;
 222     end;
 223   { check parameters }
 224   { default value for length is -32767 }
 225   if len=-32767 then
 226     len:=maxlen;
 227   { determine sign. before precision, needs 2 less calls to abs() }
 228 {$ifndef big_endian}
 229 {$ifdef SUPPORT_EXTENDED}
 230   { extended, format (MSB): 1 Sign bit, 15 bit exponent, 64 bit mantissa }
 231   sign := (TSplitExtended(d).w and $8000) <> 0;
 232   expMaximal := (TSplitExtended(d).w and $7fff) = 32767;
 233   mantZero := (TSplitExtended(d).cards[0] = 0) and
 234                   (TSplitExtended(d).cards[1] = 0);
 235 {$else SUPPORT_EXTENDED}
 236 {$ifdef SUPPORT_DOUBLE}
 237   { double, format (MSB): 1 Sign bit, 11 bit exponent, 52 bit mantissa }
 238   sign := ((TSplitDouble(d).cards[1] shr 20) and $800) <> 0;
 239   expMaximal := ((TSplitDouble(d).cards[1] shr 20) and $7ff) = 2047;
 240   mantZero := (TSplitDouble(d).cards[1] and $fffff = 0) and
 241               (TSplitDouble(d).cards[0] = 0);
 242 {$else SUPPORT_DOUBLE}
 243 {$ifdef SUPPORT_SINGLE}
 244   { single, format (MSB): 1 Sign bit, 8 bit exponent, 23 bit mantissa }
 245   sign := ((TSplitSingle(d).words[1] shr 7) and $100) <> 0;
 246   expMaximal := ((TSplitSingle(d).words[1] shr 7) and $ff) = 255;
 247   mantZero := (TSplitSingle(d).cards[0] and $7fffff = 0);
 248 {$else SUPPORT_SINGLE}
 249   {$error No big endian floating type supported yet in real2str}
 250 {$endif SUPPORT_SINGLE}
 251 {$endif SUPPORT_DOUBLE}
 252 {$endif SUPPORT_EXTENDED}
 253 {$else big_endian}
 254   {$error sign/NaN/Inf not yet supported for big endian CPU's in str_real}
 255 {$endif big_endian}
 256   if expMaximal then
 257     if mantZero then
 258       if sign then
 259         temp := '-Inf'
 260       else temp := 'Inf'
 261     else temp := 'NaN'
 262   else
 263     begin
 264       {  d:=abs(d); this converts d to double so we loose precision }
 265       { for the same reason I converted d:=frac(d) to d:=d-int(d); (PM) }
 266       if sign then
 267         d:=-d;
 268       { determine precision : maximal precision is : }
 269       currPrec := maxlen-explen-2;
 270       { this is also the maximal number of decimals !!}
 271       if f>currprec then
 272         f:=currprec;
 273       { when doing a fixed-point, we need less characters.}
 274       if (f<0) {or ((d<>0) and ((d>maxexp) and (d>minexp)))} then
 275         begin
 276         { determine maximal number of decimals }
 277           if (len>=0) and (len<minlen) then
 278             len:=minlen;
 279           if (len>0) and (len<maxlen) then
 280             currprec:=len-explen-2;
 281         end;
 282
 283       { leading zero, may be necessary for things like str(9.999:0:2) to }
 284       { be able to insert an extra character at the start of the string  }
 285       temp := ' 0';
 286       { position in the temporary output string }
 287       spos := 2;
 288       { get the integer part }
 289       correct := 0;
 290       GetIntPart(d);
 291       { now process the fractional part }
 292       if d > 1.0- roundCorr then
 293         d := frac(d);
 294       { if we have to round earlier than the amount of available precision, }
 295       { only calculate digits up to that point                              }
 296       if (f >= 0) and (currPrec > f) then
 297         currPrec := f;
 298       { if integer part was zero, go to the first significant digit of the }
 299       { fractional part                                                    }
 300       { make sure we don't get an endless loop if d = 0                    }
 301       if (spos = 2) and (d <> 0.0) then
 302         begin
 303          { take rounding errors into account }
 304           while d < 0.1-roundCorr do
 305             begin
 306               d := d * 10.0;
 307               dec(correct);
 308               { adjust the precision depending on how many digits we  }
 309               { already "processed" by multiplying by 10, but only if }
 310               { the amount of precision is specified                  }
 311               if f >= 0 then
 312                 dec(currPrec);
 313             end;
 314           dec(correct);
 315         end;
 316       { current length of the output string in endPos }
 317       endPos := spos;
 318       { always calculate at least 1 fractional digit for rounding }
 319       if (currPrec >= 0) then
 320         begin
 321           corrVal := 0.5;
 322           for fracCount := 1 to currPrec do
 323             corrVal := corrVal / 10.0;
 324           if d >= corrVal then
 325             d := d + corrVal;
 326           if int(d) = 1 then
 327             begin
 328               roundStr(temp,spos);
 329               d := frac(d);
 330             end;
 331           { calculate the necessary fractional digits }
 332           for fracCount := 1 to currPrec do
 333             begin
 334               if d > 1.0- roundCorr then
 335                 d := frac(d) * 10.0
 336               else d := d * 10.0;
 337               inc(spos);
 338               temp[spos] := chr(trunc(d)+ord('0'));
 339               if temp[spos] > '9' then
 340                 { possible because trunc and the "*10.0" aren't exact :( }
 341                 begin
 342                   temp[spos] := chr(ord(temp[spos]) - 10);
 343                   roundStr(temp,spos-1);
 344                 end;
 345             end;
 346           { new length of string }
 347           endPos := spos;
 348         end;
 349       setLength(temp,endPos);
 350       { delete leading zero if we didn't need it while rounding at the }
 351       { string level                                                   }
 352       if temp[2] = '0' then
 353         delete(temp,2,1)
 354       { the rounding caused an overflow to the next power of 10 }
 355       else inc(correct);
 356       if sign then
 357         temp[1] := '-';
 358       if (f<0) or (correct>(round(ln(maxexp)/ln(10)))) then
 359         begin
 360           insert ('.',temp,3);
 361           str(abs(correct),power);
 362           if length(power)<explen-2 then
 363             power:=copy(zero,1,explen-2-length(power))+power;
 364           if correct<0 then
 365             power:='-'+power
 366           else
 367             power:='+'+power;
 368           temp:=temp+'E'+power;
 369         end
 370       else
 371         begin
 372           if not sign then
 373             begin
 374               delete(temp,1,1);
 375               dot := 2
 376             end
 377           else
 378             dot := 3;
 379           { set zeroes and dot }
 380           if correct>=0 then
 381             begin
 382               if length(temp)<correct+dot+f-1 then
 383                 temp:=temp+copy(zero,1,correct+dot+f-length(temp));
 384               insert ('.',temp,correct+dot);
 385             end
 386           else
 387             begin
 388               correct:=abs(correct);
 389               insert(copy(zero,1,correct),temp,dot-1);
 390               insert ('.',temp,dot);
 391             end;
 392           { correct length to fit precision }
 393           if f>0 then
 394             setlength(temp,pos('.',temp)+f)
 395           else
 396             setLength(temp,pos('.',temp)-1);
 397         end;
 398     end;
 399     if length(temp)<len then
 400       s:=space(len-length(temp))+temp
 401     else s:=temp;
 402 end;
 403
 404 {
 405   $Log$
 406   Revision 1.1  2002/02/19 08:25:28  sasu
 407   Initial revision
 408
 409   Revision 1.1  2000/07/13 06:30:48  michael
 410   + Initial import
 411
 412   Revision 1.32  2000/07/07 18:03:08  jonas
 413     * changed precision for extended back (otherwise strreal2.pp in
 414       tests/test failed)
 415
 416   Revision 1.31  2000/07/06 21:09:45  florian
 417     * fixed writing of comp and extended: the precision of comp was to little
 418       while it was too high for extended
 419
 420   Revision 1.30  2000/03/26 11:36:28  jonas
 421     + $maxfpuregisters 0 for i386 in systemh (to avoid requiring too much
 422       empty FPU registers for sysstem routines
 423     * fixed bug in str_real when using :x:0
 424     * str_real now doesn't call exp() anymore at runtime, so it should
 425       require less free FPU registers now (and be slightly faster)
 426
 427   Revision 1.29  2000/03/21 12:00:30  jonas
 428     * fixed more bugs due to inexact nature of FPU
 429
 430   Revision 1.28  2000/03/17 20:20:33  jonas
 431     * fixed rounding bugs with certain formatting parameters in str_real
 432     * fixed tbs0218 so it compares both results only until max precision
 433
 434   Revision 1.27  2000/03/05 09:41:05  jonas
 435     * fixed rounding problem when writing out single/double type vars
 436
 437   Revision 1.26  2000/03/02 07:35:57  jonas
 438     * sign was not written in some cases
 439
 440   Revision 1.25  2000/02/27 14:41:25  peter
 441     * removed warnings/notes
 442
 443   Revision 1.24  2000/02/26 18:53:11  jonas
 444     * fix for lost precision because sometimes the correction value was
 445       larger than the number to be corrected
 446     * incompatibility with TP's output fixed
 447
 448   Revision 1.23  2000/02/26 15:49:40  jonas
 449     + new str_real which is completely TP compatible regarding output
 450       format and which should have no rounding errors anymore
 451
 452   Revision 1.22  2000/02/09 16:59:31  peter
 453     * truncated log
 454
 455   Revision 1.21  2000/02/09 12:17:51  peter
 456     * moved halt to system.inc
 457     * syslinux doesn't use direct asm anymore
 458
 459   Revision 1.20  2000/01/17 13:00:51  jonas
 460     + support for NaN's, cleaner support for Inf
 461
 462   Revision 1.19  2000/01/07 16:41:36  daniel
 463     * copyright 2000
 464
 465   Revision 1.18  1999/11/28 23:57:23  pierre
 466    * Infinite loop for infinite value problem fixed
 467
 468   Revision 1.17  1999/11/03 09:54:24  peter
 469     * another fix for precision
 470
 471   Revision 1.16  1999/11/03 00:55:09  pierre
 472    * problem of last commit for large d values corrected
 473
 474   Revision 1.15  1999/11/02 15:05:53  peter
 475     * better precisio by dividing only once with a calculated longint
 476       instead of multiple times by 10
 477
 478   Revision 1.14  1999/08/03 21:58:44  peter
 479     * small speed improvements
 480
 481 }