mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-27 18:13:47 +02:00
500 lines
16 KiB
PHP
500 lines
16 KiB
PHP
{
|
|
$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 symconst.pas tfloattype }
|
|
treal_type = (
|
|
rt_s32real,rt_s64real,rt_s80real,
|
|
rt_c64bit,rt_currency,rt_s128real
|
|
);
|
|
{ corresponding to single double extended fixed comp for i386 }
|
|
|
|
Procedure str_real (len,f : longint; d : ValReal; real_type :treal_type; var s : string);
|
|
{$ifdef SUPPORT_EXTENDED}
|
|
type
|
|
TSplitExtended = packed record
|
|
case byte of
|
|
0: (bytes: Array[0..9] of byte);
|
|
1: (words: Array[0..4] of word);
|
|
2: (cards: Array[0..1] of cardinal; w: word);
|
|
end;
|
|
const
|
|
maxDigits = 17;
|
|
{$else}
|
|
{$ifdef SUPPORT_DOUBLE}
|
|
type
|
|
TSplitDouble = packed record
|
|
case byte of
|
|
0: (bytes: Array[0..7] of byte);
|
|
1: (words: Array[0..3] of word);
|
|
2: (cards: Array[0..1] of cardinal);
|
|
end;
|
|
const
|
|
maxDigits = 14;
|
|
{$else}
|
|
{$ifdef SUPPORT_SINGLE}
|
|
type
|
|
TSplitSingle = packed record
|
|
case byte of
|
|
0: (bytes: Array[0..3] of byte);
|
|
1: (words: Array[0..1] of word);
|
|
2: (cards: Array[0..0] of cardinal);
|
|
end;
|
|
const
|
|
maxDigits = 9;
|
|
{$endif SUPPORT_SINGLE}
|
|
{$endif SUPPORT_DOUBLE}
|
|
{$endif SUPPORT_EXTENDED}
|
|
|
|
type
|
|
{ the value in the last position is used for rounding }
|
|
TIntPartStack = array[1..maxDigits+1] of valReal;
|
|
|
|
var
|
|
roundCorr, corrVal, factor : valReal;
|
|
spos, endpos, fracCount: longint;
|
|
correct, currprec: longint;
|
|
temp : string;
|
|
power : string[10];
|
|
sign : boolean;
|
|
dot : byte;
|
|
fraczero, expMaximal: boolean;
|
|
|
|
|
|
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';
|
|
|
|
procedure RoundStr(var s: string; lastPos: byte);
|
|
var carry: longint;
|
|
begin
|
|
carry := 1;
|
|
repeat
|
|
s[lastPos] := chr(ord(s[lastPos])+carry);
|
|
carry := 0;
|
|
if s[lastPos] > '9' then
|
|
begin
|
|
s[lastPos] := '0';
|
|
carry := 1;
|
|
end;
|
|
dec(lastPos);
|
|
until carry = 0;
|
|
end;
|
|
|
|
procedure getIntPart(d: valreal);
|
|
var
|
|
intPartStack: TIntPartStack;
|
|
intPart, stackPtr, endStackPtr, digits: longint;
|
|
overflow: boolean;
|
|
begin
|
|
{$ifdef DEBUG_NASM}
|
|
writeln(stderr,'getintpart(d) entry');
|
|
{$endif DEBUG_NASM}
|
|
{ position in the stack (gets increased before first write) }
|
|
stackPtr := 0;
|
|
{ number of digits processed }
|
|
digits := 0;
|
|
{ did we wrap around in the stack? Necessary to know whether we should round }
|
|
overflow :=false;
|
|
{ generate a list consisting of d, d/10, d/100, ... until d < 1.0 }
|
|
while d > 1.0-roundCorr do
|
|
begin
|
|
inc(stackPtr);
|
|
inc(digits);
|
|
if stackPtr > maxDigits+1 then
|
|
begin
|
|
stackPtr := 1;
|
|
overflow := true;
|
|
end;
|
|
intPartStack[stackPtr] := d;
|
|
d := d / 10.0;
|
|
end;
|
|
{ if no integer part, exit }
|
|
if digits = 0 then
|
|
exit;
|
|
endStackPtr := stackPtr+1;
|
|
if endStackPtr > maxDigits + 1 then
|
|
endStackPtr := 1;
|
|
{ now, all digits are calculated using trunc(d*10^(-n)-int(d*10^(-n-1))*10) }
|
|
corrVal := 0.0;
|
|
{ the power of 10 with which the resulting string has to be "multiplied" }
|
|
{ if the decimal point is placed after the first significant digit }
|
|
correct := digits-1;
|
|
{$ifdef DEBUG_NASM}
|
|
writeln(stderr,'endStackPtr = ',endStackPtr);
|
|
{$endif DEBUG_NASM}
|
|
repeat
|
|
if (currprec > 0) then
|
|
begin
|
|
intPart:= trunc(intPartStack[stackPtr]-corrVal);
|
|
dec(currPrec);
|
|
inc(spos);
|
|
temp[spos] := chr(intPart+ord('0'));
|
|
{$ifdef DEBUG_NASM}
|
|
writeln(stderr,'stackptr =',stackptr,' intpart = ',intpart);
|
|
{$endif DEBUG_NASM}
|
|
if temp[spos] > '9' then
|
|
begin
|
|
temp[spos] := chr(ord(temp[spos])-10);
|
|
roundStr(temp,spos-1);
|
|
end;
|
|
end;
|
|
corrVal := int(intPartStack[stackPtr]) * 10.0;
|
|
{$ifdef DEBUG_NASM}
|
|
writeln(stderr,'trunc(corrval) = ',trunc(corrval));
|
|
{$endif DEBUG_NASM}
|
|
dec(stackPtr);
|
|
if stackPtr = 0 then
|
|
stackPtr := maxDigits+1;
|
|
until (overflow and (stackPtr = endStackPtr)) or
|
|
(not overflow and (stackPtr = maxDigits+1)) or (currPrec = 0);
|
|
{ round if we didn't use all available digits yet and if the }
|
|
{ remainder is > 5 }
|
|
if (overflow or
|
|
(stackPtr < maxDigits+1)) then
|
|
begin
|
|
{ we didn't use all available digits of the whole part -> make sure }
|
|
{ the fractional part is not used for rounding later }
|
|
currprec := -1;
|
|
{ instead, round based on the next whole digit }
|
|
if (trunc(intPartStack[stackPtr]-corrVal) > 5.0 - roundCorr) then
|
|
roundStr(temp,spos);
|
|
end;
|
|
{$ifdef DEBUG_NASM}
|
|
writeln(stderr,'temp at getintpart exit is = ',temp);
|
|
{$endif DEBUG_NASM}
|
|
end;
|
|
|
|
begin
|
|
case real_type of
|
|
rt_s32real :
|
|
begin
|
|
maxlen:=16;
|
|
minlen:=8;
|
|
explen:=4;
|
|
{ correction used with comparing to avoid rounding/precision errors }
|
|
roundCorr := (1/exp((16-4-3)*ln(10)));
|
|
end;
|
|
rt_s64real :
|
|
begin
|
|
{ if the maximum suppported type is double, we can print out one digit }
|
|
{ less, because otherwise we can't round properly and 1e-400 becomes }
|
|
{ 0.99999999999e-400 (JM) }
|
|
{$ifdef support_extended}
|
|
maxlen:=23;
|
|
{ correction used with comparing to avoid rounding/precision errors }
|
|
roundCorr := (1/exp((23-5-3)*ln(10)));
|
|
{$else support_extended}
|
|
{$ifdef support_double}
|
|
maxlen := 22;
|
|
{ correction used with comparing to avoid rounding/precision errors }
|
|
roundCorr := (1/exp((22-4-3)*ln(10)));
|
|
{$endif support_double}
|
|
{$endif support_extended}
|
|
minlen:=9;
|
|
explen:=5;
|
|
end;
|
|
rt_s80real :
|
|
begin
|
|
{ Different in TP help, but this way the output is the same (JM) }
|
|
maxlen:=25;
|
|
minlen:=10;
|
|
explen:=6;
|
|
{ correction used with comparing to avoid rounding/precision errors }
|
|
roundCorr := (1/exp((25-6-3)*ln(10)));
|
|
end;
|
|
rt_c64bit :
|
|
begin
|
|
maxlen:=23;
|
|
minlen:=10;
|
|
{ according to TP (was 5) (FK) }
|
|
explen:=6;
|
|
{ correction used with comparing to avoid rounding/precision errors }
|
|
roundCorr := (1/exp((23-6-3)*ln(10)));
|
|
end;
|
|
rt_currency :
|
|
begin
|
|
{ Different in TP help, but this way the output is the same (JM) }
|
|
maxlen:=25;
|
|
minlen:=10;
|
|
explen:=0;
|
|
{ correction used with comparing to avoid rounding/precision errors }
|
|
roundCorr := (1/exp((25-6-3)*ln(10)));
|
|
end;
|
|
rt_s128real :
|
|
begin
|
|
{ Different in TP help, but this way the output is the same (JM) }
|
|
maxlen:=25;
|
|
minlen:=10;
|
|
explen:=6;
|
|
{ correction used with comparing to avoid rounding/precision errors }
|
|
roundCorr := (1/exp((25-6-3)*ln(10)));
|
|
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() }
|
|
{$ifndef endian_big}
|
|
{$ifdef SUPPORT_EXTENDED}
|
|
{ extended, format (MSB): 1 Sign bit, 15 bit exponent, 64 bit mantissa }
|
|
sign := (TSplitExtended(d).w and $8000) <> 0;
|
|
expMaximal := (TSplitExtended(d).w and $7fff) = 32767;
|
|
fraczero := (TSplitExtended(d).cards[0] = 0) and
|
|
((TSplitExtended(d).cards[1] and $7fffffff) = 0);
|
|
{$else SUPPORT_EXTENDED}
|
|
{$ifdef SUPPORT_DOUBLE}
|
|
{$ifdef CPUARM}
|
|
{ double, format (MSB): 1 Sign bit, 11 bit exponent, 52 bit mantissa }
|
|
{ high and low dword are swapped when using the arm fpa }
|
|
sign := ((TSplitDouble(d).cards[0] shr 20) and $800) <> 0;
|
|
expMaximal := ((TSplitDouble(d).cards[0] shr 20) and $7ff) = 2047;
|
|
fraczero:= (TSplitDouble(d).cards[0] and $fffff = 0) and
|
|
(TSplitDouble(d).cards[1] = 0);
|
|
{$else CPUARM}
|
|
{ double, format (MSB): 1 Sign bit, 11 bit exponent, 52 bit mantissa }
|
|
sign := ((TSplitDouble(d).cards[1] shr 20) and $800) <> 0;
|
|
expMaximal := ((TSplitDouble(d).cards[1] shr 20) and $7ff) = 2047;
|
|
fraczero := (TSplitDouble(d).cards[1] and $fffff = 0) and
|
|
(TSplitDouble(d).cards[0] = 0);
|
|
{$endif CPUARM}
|
|
{$else SUPPORT_DOUBLE}
|
|
{$ifdef SUPPORT_SINGLE}
|
|
{ single, format (MSB): 1 Sign bit, 8 bit exponent, 23 bit mantissa }
|
|
sign := ((TSplitSingle(d).words[1] shr 7) and $100) <> 0;
|
|
expMaximal := ((TSplitSingle(d).words[1] shr 7) and $ff) = 255;
|
|
fraczero := (TSplitSingle(d).cards[0] and $7fffff = 0);
|
|
{$else SUPPORT_SINGLE}
|
|
{$error No little endian floating type supported yet in real2str}
|
|
{$endif SUPPORT_SINGLE}
|
|
{$endif SUPPORT_DOUBLE}
|
|
{$endif SUPPORT_EXTENDED}
|
|
{$else endian_big}
|
|
{$ifdef SUPPORT_EXTENDED}
|
|
{$error sign/NaN/Inf not yet supported for big endian CPU's in str_real}
|
|
{$else SUPPORT_EXTENDED}
|
|
{$ifdef SUPPORT_DOUBLE}
|
|
{ double, format (MSB): 1 Sign bit, 11 bit exponent, 52 bit mantissa }
|
|
sign := ((TSplitDouble(d).cards[0] shr 20) and $800) <> 0;
|
|
expMaximal := ((TSplitDouble(d).cards[0] shr 20) and $7ff) = 2047;
|
|
fraczero:= (TSplitDouble(d).cards[0] and $fffff = 0) and
|
|
(TSplitDouble(d).cards[1] = 0);
|
|
{$else SUPPORT_DOUBLE}
|
|
{$ifdef SUPPORT_SINGLE}
|
|
{ single, format (MSB): 1 Sign bit, 8 bit exponent, 23 bit mantissa }
|
|
sign := ((TSplitSingle(d).bytes[0] and $80)) <> 0;
|
|
expMaximal := ((TSplitSingle(d).words[0] shr 7) and $ff) = 255;
|
|
fraczero:= (TSplitSingle(d).cards[0] and $7fffff = 0);
|
|
{$else SUPPORT_SINGLE}
|
|
{$error No big endian floating type supported yet in real2str}
|
|
{$endif SUPPORT_SINGLE}
|
|
{$endif SUPPORT_DOUBLE}
|
|
{$endif SUPPORT_EXTENDED}
|
|
{$endif endian}
|
|
if expMaximal then
|
|
if fraczero then
|
|
if sign then
|
|
temp := '-Inf'
|
|
else temp := '+Inf'
|
|
else temp := 'Nan'
|
|
else
|
|
begin
|
|
{ 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;
|
|
{ determine precision : maximal precision is : }
|
|
currPrec := maxlen-explen-2;
|
|
{ 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) and (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-2;
|
|
end;
|
|
|
|
{ leading zero, may be necessary for things like str(9.999:0:2) to }
|
|
{ be able to insert an extra character at the start of the string }
|
|
temp := ' 0';
|
|
{ position in the temporary output string }
|
|
spos := 2;
|
|
{ get the integer part }
|
|
correct := 0;
|
|
GetIntPart(d);
|
|
{ now process the fractional part }
|
|
if d > 1.0- roundCorr then
|
|
d := frac(d);
|
|
{ if we have to round earlier than the amount of available precision, }
|
|
{ only calculate digits up to that point }
|
|
if (f >= 0) and (currPrec > f) then
|
|
currPrec := f;
|
|
{ if integer part was zero, go to the first significant digit of the }
|
|
{ fractional part }
|
|
{ make sure we don't get an endless loop if d = 0 }
|
|
if (spos = 2) and (d <> 0.0) then
|
|
begin
|
|
{ take rounding errors into account }
|
|
while d < 0.1-roundCorr do
|
|
begin
|
|
d := d * 10.0;
|
|
dec(correct);
|
|
{ adjust the precision depending on how many digits we }
|
|
{ already "processed" by multiplying by 10, but only if }
|
|
{ the amount of precision is specified }
|
|
if f >= 0 then
|
|
dec(currPrec);
|
|
end;
|
|
dec(correct);
|
|
end;
|
|
{ current length of the output string in endPos }
|
|
endPos := spos;
|
|
{ always calculate at least 1 fractional digit for rounding }
|
|
if (currPrec >= 0) then
|
|
begin
|
|
corrVal := 0.5;
|
|
factor := 1;
|
|
for fracCount := 1 to currPrec do
|
|
factor := factor * 10.0;
|
|
corrval := corrval / factor;
|
|
if d >= corrVal then
|
|
d := d + corrVal;
|
|
if int(d) = 1 then
|
|
begin
|
|
roundStr(temp,spos);
|
|
d := frac(d);
|
|
end;
|
|
{ calculate the necessary fractional digits }
|
|
for fracCount := 1 to currPrec do
|
|
begin
|
|
if d > 1.0- roundCorr then
|
|
d := frac(d) * 10.0
|
|
else d := d * 10.0;
|
|
inc(spos);
|
|
temp[spos] := chr(trunc(d)+ord('0'));
|
|
if temp[spos] > '9' then
|
|
{ possible because trunc and the "*10.0" aren't exact :( }
|
|
begin
|
|
temp[spos] := chr(ord(temp[spos]) - 10);
|
|
roundStr(temp,spos-1);
|
|
end;
|
|
end;
|
|
{ new length of string }
|
|
endPos := spos;
|
|
end;
|
|
setLength(temp,endPos);
|
|
{ delete leading zero if we didn't need it while rounding at the }
|
|
{ string level }
|
|
if temp[2] = '0' then
|
|
delete(temp,2,1)
|
|
{ the rounding caused an overflow to the next power of 10 }
|
|
else inc(correct);
|
|
if sign then
|
|
temp[1] := '-';
|
|
if (f<0) or (correct>(round(ln(maxexp)/ln(10)))) 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-1 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
|
|
setlength(temp,pos('.',temp)+f)
|
|
else
|
|
setLength(temp,pos('.',temp)-1);
|
|
end;
|
|
end;
|
|
if length(temp)<len then
|
|
s:=space(len-length(temp))+temp
|
|
else s:=temp;
|
|
end;
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.16 2004-05-31 20:25:04 peter
|
|
* removed warnings
|
|
|
|
Revision 1.15 2004/03/13 18:47:57 florian
|
|
* "improved" behavior of real2str for arm, still needs fixing
|
|
|
|
Revision 1.14 2004/03/13 18:33:52 florian
|
|
* fixed some arm related real stuff
|
|
|
|
Revision 1.13 2003/12/29 19:19:21 jonas
|
|
* fixed NaN/Inf detection for single/double
|
|
|
|
Revision 1.12 2003/12/08 17:45:00 peter
|
|
* currency support
|
|
* dropped fixed16/32 support
|
|
|
|
Revision 1.11 2003/10/26 16:56:44 jonas
|
|
* fixed web bug 2643
|
|
|
|
Revision 1.10 2003/09/06 17:06:59 florian
|
|
* fixed Nan and +Inf string
|
|
|
|
Revision 1.9 2003/09/06 16:48:35 florian
|
|
* fixed real2str for -Inf and Inf
|
|
|
|
Revision 1.8 2003/05/16 23:22:31 jonas
|
|
* moved all loal variables to one block (necessary for ppc until nested
|
|
procedures are properly supported)
|
|
|
|
Revision 1.7 2002/10/04 16:41:17 jonas
|
|
* fixed web bug 2131
|
|
|
|
Revision 1.6 2002/09/07 15:07:46 peter
|
|
* old logs removed and tabs fixed
|
|
|
|
}
|