freepascal.compiler/rtl/inc/real2str.inc

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999-2000 by Michael Van Canneyt,
    member of the Free Pascal development team

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

type
  { See symdefh.inc tfloattyp }
  treal_type = (rt_s32real,rt_s64real,rt_s80real,rt_c64bit,rt_f16bit,rt_f32bit);
  { corresponding to single   double   extended   fixed      comp for i386 }

const
   { do not use real constants else you get rouding errors }
   i10 : longint = 10;
   i2  : longint = 2;
   i1  : longint = 1;

   { we can use this conditional if the Inf const is defined
     in processor specific code PM }
{$ifdef FPC_HAS_INFINITY_CONST}
   {$define FPC_INFINITY_FOR_REAL2STR}
{$else not  FPC_HAS_INFINITY_CONST}
   { To avoid problems with infinity just
     issue it in byte representation to be endianness independant PM }
{$ifndef FPC_INFINITY_FOR_REAL2STR}
{$ifdef SUPPORT_EXTENDED}
   { extended is not IEEE so its processor specific
     so I only allow it for i386 PM }
{$ifdef i386}
   {$define FPC_INFINITY_FOR_REAL2STR}
   InfArray : {extended} array[0..9] of byte = ($0,$0,$0,$0,$0,$0,$0,$80,$ff,$7f);
{$endif i386}
{$endif SUPPORT_EXTENDED}
{$endif not FPC_INFINITY_FOR_REAL2STR}

{$ifndef FPC_INFINITY_FOR_REAL2STR}
{$ifdef SUPPORT_DOUBLE}
   {$define FPC_INFINITY_FOR_REAL2STR}
   InfArray : {double} array[0..9] of byte = ($0,$0,$0,$0,$0,$0,$f0,$7f);
{$endif SUPPORT_DOUBLE}
{$endif not FPC_INFINITY_FOR_REAL2STR}

{$ifndef FPC_INFINITY_FOR_REAL2STR}
{$ifdef SUPPORT_SINGLE}
   {$define FPC_INFINITY_FOR_REAL2STR}
   InfArray : {single} array[0..3] of byte = ($0,$0,$80,$7f);
{$endif SUPPORT_SINGLE}
{$endif not FPC_INFINITY_FOR_REAL2STR}

{$ifndef FPC_INFINITY_FOR_REAL2STR}
    {$warning don't know Infinity values }
{$endif not FPC_INFINITY_FOR_REAL2STR}
{$endif not FPC_HAS_INFINITY_CONST}

Procedure str_real (len,f : longint; d : ValReal; real_type :treal_type; var s : string);
{
  These numbers are for the double type...
  At the moment these are mapped onto a double but this may change
  in the future !
}
var  maxlen : longint;   { Maximal length of string for float }
     minlen : longint;   { Minimal length of string for float }
     explen : longint;   { Length of exponent, including E and sign.
                           Must be strictly larger than 2 }
const
      maxexp = 1e+35;   { Maximum value for decimal expressions }
      minexp = 1e-35;   { Minimum value for decimal expressions }
      zero   = '0000000000000000000000000000000000000000';

var correct : longint;  { Power correction }
    currprec : longint;
    il,il2,roundcorr : Valreal;
    temp : string;
    power : string[10];
    sign : boolean;
    i : integer;
    dot : byte;
    currp : pchar;
begin
  case real_type of
    rt_s32real :
      begin
         maxlen:=16;
         minlen:=8;
         explen:=4;
      end;
    rt_s64real :
      begin
         maxlen:=23;
         minlen:=9;
         explen:=5;
      end;
    rt_s80real :
      begin
         maxlen:=26;
         minlen:=10;
         explen:=6;
      end;
    rt_c64bit  :
      begin
         maxlen:=22;
         minlen:=9;
         { according to TP (was 5) (FK) }
         explen:=6;
      end;
    rt_f16bit  :
      begin
         maxlen:=16;
         minlen:=8;
         explen:=4;
      end;
    rt_f32bit  :
      begin
         maxlen:=16;
         minlen:=8;
         explen:=4;
      end;
    end;
  { check parameters }
  { default value for length is -32767 }
  if len=-32767 then
    len:=maxlen;
  { determine sign. before precision, needs 2 less calls to abs() }
  sign:=d<0;
  { the creates a cannot determine which overloaded function to call
  if d is extended !!!
  we should prefer real_to_real on real_to_longint !!
  corrected in compiler }

  {  d:=abs(d); this converts d to double so we loose precision }
  { for the same reason I converted d:=frac(d) to d:=d-int(d); (PM) }
  if sign then
    d:=-d;

{$ifdef FPC_INFINITY_FOR_REAL2STR}
{$ifndef FPC_HAS_INFINITY_CONST}
    if d=ValReal(InfArray) then
{$else FPC_HAS_INFINITY_CONST}
    if d=Inf then
{$endif FPC_HAS_INFINITY_CONST}
      begin
        if sign then
          s:='-Inf'
        else
          s:='Inf';
        exit;
      end;
{$endif FPC_INFINITY_FOR_REAL2STR}
  { determine precision : maximal precision is : }
  currprec:=maxlen-explen-3;
  { this is also the maximal number of decimals !!}
  if f>currprec then
    f:=currprec;
  { when doing a fixed-point, we need less characters.}
  if (f<0) or ( (d<>0) and ((d>maxexp) or (d<minexp))) then
    begin
    { determine maximal number of decimals }
      if (len>=0) and (len<minlen) then
        len:=minlen;
      if (len>0) and (len<maxlen) then
        currprec:=len-explen-3;
    end;
  { convert to standard form. }
  correct:=0;
  if d>=i10 then
   begin
     il:=i1;
     il2:=i10;
     repeat
       il:=il2;
       il2:=il*i10;
       inc(correct);
     until (d<il2);
     d:=d/il;
   end
  else
   if (d<1) and (d<>0) then
    begin
      while d<1 do
       begin
         d:=d*i10;
         dec(correct);
       end;
    end;
  { RoundOff }
  roundcorr:=extended(i1)/extended(i2);
  if f<0 then
    for i:=1 to currprec do roundcorr:=roundcorr/i10
  else
    begin
      if correct+f<0 then
       begin
         for i:=1 to abs(correct+f) do
          roundcorr:=roundcorr*i10;
       end
      else
       begin
         for i:=1 to correct+f do
          roundcorr:=roundcorr/i10;
       end;
    end;
  d:=d+roundcorr;
  { 0.99 + 0.05 > 1.0 ! Fix this by dividing the results >=10 first (PV) }
  while (d>=10.0) do
   begin
     d:=d/i10;
     inc(correct);
   end;
  { Now we have a standard expression : sign d *10^correct
    where  1<d<10 or d=0 ... }
  { get first character }
  currp:=pchar(@temp[1]);
  if sign then
    currp^:='-'
  else
    currp^:=' ';
  inc(currp);
  currp^:=chr(ord('0')+trunc(d));
  inc(currp);
  d:=d-int(d);
  { Start making the string }
  for i:=1 to currprec do
   begin
     d:=d*i10;
     currp^:=chr(ord('0')+trunc(d));
     inc(currp);
     d:=d-int(d);
   end;
  temp[0]:=chr(currp-pchar(@temp[1]));
  { Now we need two different schemes for the different
    representations. }
  if (f<0) or (correct>maxexp) then
    begin
      insert ('.',temp,3);
      str(abs(correct),power);
      if length(power)<explen-2 then
       power:=copy(zero,1,explen-2-length(power))+power;
      if correct<0 then
        power:='-'+power
      else
        power:='+'+power;
      temp:=temp+'E'+power;
    end
  else
    begin
      if not sign then
       begin
         delete (temp,1,1);
         dot:=2;
       end
      else
       dot:=3;
      { set zeroes and dot }
      if correct>=0 then
       begin
         if length(temp)<correct+dot+f then
          temp:=temp+copy(zero,1,correct+dot+f-length(temp));
         insert ('.',temp,correct+dot);
       end
      else
       begin
         correct:=abs(correct);
         insert(copy(zero,1,correct),temp,dot-1);
         insert ('.',temp,dot);
       end;
      { correct length to fit precision }
      if f>0 then
       temp[0]:=chr(pos('.',temp)+f)
      else
       temp[0]:=chr(pos('.',temp)-1);
    end;
  if length(temp)<len then
    s:=space(len-length(temp))+temp
  else
    s:=temp;
end;

{
  $Log$
  Revision 1.19  2000-01-07 16:41:36  daniel
    * copyright 2000

  Revision 1.18  1999/11/28 23:57:23  pierre
   * Infinite loop for infinite value problem fixed

  Revision 1.17  1999/11/03 09:54:24  peter
    * another fix for precision

  Revision 1.16  1999/11/03 00:55:09  pierre
   * problem of last commit for large d values corrected

  Revision 1.15  1999/11/02 15:05:53  peter
    * better precisio by dividing only once with a calculated longint
      instead of multiple times by 10

  Revision 1.14  1999/08/03 21:58:44  peter
    * small speed improvements

  Revision 1.13  1999/05/06 09:05:12  peter
    * generic write_float str_float

  Revision 1.12  1999/03/10 21:49:02  florian
    * str and val for extended use now int constants to minimize
      rounding error

  Revision 1.11  1999/02/16 00:49:20  peter
    * fixed rounding when correct+f < 0

  Revision 1.10  1998/08/11 21:39:06  peter
    * splitted default_extended from support_extended

  Revision 1.9  1998/08/11 00:05:25  peter
    * $ifdef ver0_99_5 updates

  Revision 1.8  1998/08/10 15:56:30  peter
    * fixed 0_9_5 typo

  Revision 1.7  1998/08/08 12:28:12  florian
    * a lot small fixes to the extended data type work

  Revision 1.6  1998/07/18 17:14:22  florian
    * strlenint type implemented

  Revision 1.5  1998/07/13 21:19:10  florian
    * some problems with ansi string support fixed

  Revision 1.4  1998/06/18 08:15:33  michael
  + Fixed error when printing zero. len was calculated wron.

  Revision 1.3  1998/05/12 10:42:45  peter
    * moved getopts to inc/, all supported OS's need argc,argv exported
    + strpas, strlen are now exported in the systemunit
    * removed logs
    * removed $ifdef ver_above

  Revision 1.2  1998/04/07 22:40:46  florian
    * final fix of comp writing
}