mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-05 09:18:15 +02:00
- removed old float-to-string and string-to-float conversion code
git-svn-id: trunk@45401 -
This commit is contained in:
Jonas Maebe
parent
4c9fae1e35
commit
f9672b53a2
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -10956,7 +10956,6 @@ rtl/inc/pagemem.pp svneol=native#text/plain
|
||||
rtl/inc/psabieh.inc svneol=native#text/plain
|
||||
rtl/inc/psabiehh.inc svneol=native#text/plain
|
||||
rtl/inc/readme -text
|
||||
rtl/inc/real2str.inc svneol=native#text/plain
|
||||
rtl/inc/resh.inc svneol=native#text/plain
|
||||
rtl/inc/rtti.inc svneol=native#text/plain
|
||||
rtl/inc/rttidecl.inc svneol=native#text/plain
|
||||
|
||||
@ -91,7 +91,9 @@ begin
|
||||
AddInclude('$(CPU).inc');
|
||||
AddInclude('fastmove.inc',[i386],AllOSes);
|
||||
AddInclude('math.inc');
|
||||
AddInclude('real2str.inc');
|
||||
AddInclude('flt_conv.inc');
|
||||
AddInclude('flt_core.inc');
|
||||
AddInclude('flt_pack.inc');
|
||||
AddInclude('systhrd.inc',AllWindowsOSes+[Netware,Netwlibc,EMX,OS2]);
|
||||
// Unix implementations
|
||||
AddInclude('osdefs.inc',AllUnixOSes);
|
||||
|
||||
@ -4,7 +4,7 @@
|
||||
# System unit include files. These are composed from header and
|
||||
# implementation files.
|
||||
|
||||
SYSNAMES=systemh heaph mathh filerec textrec system real2str sstrings innr \
|
||||
SYSNAMES=systemh heaph mathh filerec textrec system flt_conv flt_core flt_pack sstrings innr \
|
||||
file typefile text rtti heap astrings objpas objpash except int64 \
|
||||
generic dynarr varianth variant wstrings compproc
|
||||
|
||||
|
||||
@ -13,7 +13,7 @@ innr.inc Internal function delcarations.
|
||||
int64.inc Support for 64-bit integer arithmetic.
|
||||
lstrings.pp LongStrings routine implementation.
|
||||
mathh.inc Declarations of mathematical functions.
|
||||
real2str.inc Routine to convert floating point numbers to strings.
|
||||
flt_*.inc Routines to convert floating point numbers to strings and vice versa.
|
||||
rtti.inc Delphi like runtime type information
|
||||
sstrings.inc ShortStrings (TP/BP pascal like strings) implementation.
|
||||
system.inc OS and Processor independent implementation part of system unit.
|
||||
|
||||
@ -1,543 +0,0 @@
|
||||
{
|
||||
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_sc80real,
|
||||
rt_c64bit,rt_currency,rt_s128real
|
||||
);
|
||||
{ corresponding to single double extended fixed comp for i386 }
|
||||
|
||||
{$if not declared(mul_by_power10)}
|
||||
function mul_by_power10 (x : ValReal; power : integer) : ValReal; forward;
|
||||
{$endif}
|
||||
|
||||
Procedure str_real (len,f : longint; d : ValReal; real_type :treal_type; out 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}
|
||||
{$ifndef cpujvm}
|
||||
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;
|
||||
{$endif}
|
||||
const
|
||||
maxDigits = 15;
|
||||
{$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
|
||||
{$ifdef cpujvm}
|
||||
doublebits: int64;
|
||||
{$endif}
|
||||
roundCorr, corrVal, factor : valReal;
|
||||
high_exp10_reduced,
|
||||
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 (int(intPartStack[stackPtr]-corrVal) >= 5.0) then
|
||||
roundStr(temp,spos);
|
||||
end;
|
||||
{$ifdef DEBUG_NASM}
|
||||
writeln(stderr,'temp at getintpart exit is = ',temp);
|
||||
{$endif DEBUG_NASM}
|
||||
end;
|
||||
|
||||
function reduce_exponent (d : ValReal; out scaled : ValReal) : longint;
|
||||
{ Returns decimal exponent which was used for scaling, and a scaled value out }
|
||||
const
|
||||
C_LN10 = ln(10);
|
||||
var
|
||||
log10_d : longint;
|
||||
begin
|
||||
reduce_exponent := 0;
|
||||
if d<>0 then
|
||||
begin
|
||||
// get exponent approximation ["d" is assumed to be non-negative]
|
||||
log10_d:=trunc(ln(d)/C_LN10);
|
||||
// trying to stay at least 1 digit away from introducing integer/fractional part
|
||||
if log10_d > maxDigits+1 then
|
||||
reduce_exponent := log10_d-maxDigits
|
||||
else
|
||||
if log10_d < -(maxDigits+1) then
|
||||
reduce_exponent := log10_d+maxDigits
|
||||
// else
|
||||
// the number is already suitable enough
|
||||
end;
|
||||
// do scaling if needed
|
||||
if reduce_exponent<>0
|
||||
then scaled := mul_by_power10(d,-reduce_exponent) // denormals should be handled properly by this call
|
||||
else scaled := d;
|
||||
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.1920928955e-07;
|
||||
end;
|
||||
rt_s64real :
|
||||
begin
|
||||
maxlen := 22;
|
||||
{ correction used with comparing to avoid rounding/precision errors }
|
||||
roundCorr := 2.2204460493e-16;
|
||||
minlen:=9;
|
||||
explen:=5;
|
||||
end;
|
||||
rt_s80real,
|
||||
rt_sc80real:
|
||||
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.0842021725e-19;
|
||||
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 := 2.2204460493e-16;
|
||||
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.0842021725e-19;
|
||||
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.0842021725e-19;
|
||||
end;
|
||||
else
|
||||
begin
|
||||
{ keep JVM byte code verifier happy }
|
||||
maxlen:=0;
|
||||
minlen:=0;
|
||||
explen:=0;
|
||||
roundCorr:=0;
|
||||
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 FPC_DOUBLE_HILO_SWAPPED}
|
||||
{ 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 FPC_DOUBLE_HILO_SWAPPED}
|
||||
{ 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 FPC_DOUBLE_HILO_SWAPPED}
|
||||
{$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}
|
||||
{$ifdef cpujvm}
|
||||
doublebits := JLDouble.doubleToLongBits(d);
|
||||
sign := doublebits<0;
|
||||
expMaximal := (doublebits shr (32+20)) and $7ff = 2047;
|
||||
fraczero:= (((doublebits shr 32) and $fffff) = 0) and
|
||||
(longint(doublebits)=0);
|
||||
{$else cpujvm}
|
||||
{ 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);
|
||||
{$endif cpujvm}
|
||||
{$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;
|
||||
|
||||
// workaround to make follow-up things go somewhat faster
|
||||
high_exp10_reduced := 0;
|
||||
case real_type of
|
||||
// blacklist, in order of increasing headache:
|
||||
//? rt_s32real :;
|
||||
// ? needs additional testing to ensure any reasonable benefit
|
||||
// without lost of accuracy due to an extra conversion
|
||||
rt_c64bit, rt_currency :;
|
||||
// no much sense to touch them
|
||||
else
|
||||
// acceptable:
|
||||
// ? rt_s32real [see above]
|
||||
// rt_s64real
|
||||
// rt_s80real, rt_sc80real
|
||||
// ? rt_s128real [have not tried]
|
||||
high_exp10_reduced := reduce_exponent(d,d);
|
||||
end;
|
||||
|
||||
{ get the integer part }
|
||||
correct := 0;
|
||||
GetIntPart(d);
|
||||
|
||||
inc(correct,high_exp10_reduced); // end of workaround
|
||||
|
||||
{ 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;
|
||||
{ for single, we may write more significant digits than are available,
|
||||
so the rounding correction itself can show up -> don't round in that
|
||||
case
|
||||
}
|
||||
if real_type<>rt_s32real then
|
||||
d:=d+d*roundCorr;
|
||||
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 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;
|
||||
|
||||
|
||||
Procedure str_real_iso (len,f : longint; d : ValReal; real_type :treal_type; out s : string);
|
||||
var
|
||||
i : Integer;
|
||||
begin
|
||||
str_real(len,f,d,real_type,s);
|
||||
for i:=1 to Length(s) do
|
||||
if s[i]='E' then
|
||||
s[i]:='e';
|
||||
end;
|
||||
|
||||
|
||||
@ -490,11 +490,7 @@ end;
|
||||
{ compilerproc name will fail (JM) }
|
||||
|
||||
{$ifndef FPUNONE}
|
||||
{$ifdef FLOAT_ASCII_FALLBACK}
|
||||
{$I real2str.inc}
|
||||
{$else not FLOAT_ASCII_FALLBACK}
|
||||
{$I flt_conv.inc}
|
||||
{$endif FLOAT_ASCII_FALLBACK}
|
||||
{$endif}
|
||||
|
||||
{$ifndef FPUNONE}
|
||||
@ -1566,349 +1562,6 @@ end;
|
||||
end;
|
||||
{$endif CPU16 or CPU8}
|
||||
|
||||
{$ifdef FLOAT_ASCII_FALLBACK}
|
||||
{$ifndef FPUNONE}
|
||||
const
|
||||
{$ifdef FPC_HAS_TYPE_EXTENDED}
|
||||
valmaxexpnorm=4932;
|
||||
mantissabits=64;
|
||||
{$else}
|
||||
{$ifdef FPC_HAS_TYPE_DOUBLE}
|
||||
valmaxexpnorm=308;
|
||||
mantissabits=53;
|
||||
{$else}
|
||||
{$ifdef FPC_HAS_TYPE_SINGLE}
|
||||
valmaxexpnorm=38;
|
||||
mantissabits=24;
|
||||
{$else}
|
||||
{$error Unknown floating point precision }
|
||||
{$endif}
|
||||
{$endif}
|
||||
{$endif}
|
||||
{$endif}
|
||||
|
||||
{$ifndef FPUNONE}
|
||||
|
||||
(******************
|
||||
|
||||
Derived from: ".\Free Pascal\source\rtl\inc\genmath.inc"
|
||||
|
||||
Origin: "fast 10^n routine"
|
||||
function FPower10(val: Extended; Power: Longint): Extended;
|
||||
|
||||
Changes:
|
||||
> adapted to "ValReal", so float can be single/double/extended
|
||||
> slightly changed arrays [redundant 58+2 float constants gone away]
|
||||
> added some checks etc..
|
||||
|
||||
Notes:
|
||||
> denormalization and overflow should go smooth if corresponding
|
||||
FPU exceptions are masked [no external care needed by now]
|
||||
> adaption to real48 and real128 is not hard if one needed
|
||||
|
||||
******************)
|
||||
//
|
||||
function mul_by_power10(x:ValReal;power:integer):ValReal;
|
||||
//
|
||||
// result:=X*(10^power)
|
||||
//
|
||||
// Routine achieves result with no more than 3 floating point mul/div's.
|
||||
// Up to ABS(power)=31, only 1 floating point mul/div is needed.
|
||||
//
|
||||
// Limitations:
|
||||
// for ValReal=extended : power=-5119..+5119
|
||||
// for ValReal=double : power=-319..+319
|
||||
// for ValReal=single : power=-63..+63
|
||||
//
|
||||
// If "power" is beyond this limits, routine gives up and returns 0/+INF/-INF.
|
||||
// This is not generally correct, but should be ok when routine is used only
|
||||
// as "VAL"-helper, since "x" exponent is reasonably close to 0 in this case.
|
||||
//
|
||||
//==================================
|
||||
{$IF DECLARED(C_HIGH_EXPBITS_5TO8)}
|
||||
{$ERROR C_HIGH_EXPBITS_5TO8 declared somewhere in scope}
|
||||
{$ENDIF}
|
||||
|
||||
{$IF DECLARED(C_HIGH_EXPBITS_9ANDUP)}
|
||||
{$ERROR C_HIGH_EXPBITS_9ANDUP declared somewhere in scope}
|
||||
{$ENDIF}
|
||||
|
||||
{$IF SIZEOF(ValReal)=10}
|
||||
//==================================
|
||||
// assuming "type ValReal=extended;"
|
||||
//
|
||||
const
|
||||
C_MAX_POWER = 5119;
|
||||
|
||||
C_HIGH_EXPBITS_5TO8 = 15;
|
||||
C_HIGH_EXPBITS_9ANDUP = 9;
|
||||
|
||||
{$ELSEIF SIZEOF(ValReal)=8}
|
||||
//==================================
|
||||
// assuming "type ValReal=double;"
|
||||
//
|
||||
const
|
||||
C_MAX_POWER = 319;
|
||||
|
||||
C_HIGH_EXPBITS_5TO8 = 9;
|
||||
|
||||
{$ELSEIF SIZEOF(ValReal)=4}
|
||||
//==================================
|
||||
// assuming "type ValReal=single;"
|
||||
//
|
||||
const
|
||||
C_MAX_POWER = 63;
|
||||
|
||||
{$ELSE}
|
||||
//==================================
|
||||
// assuming "ValReal=?"
|
||||
//
|
||||
{$ERROR Unsupported ValReal type}
|
||||
{$ENDIF}
|
||||
|
||||
//==================================
|
||||
const
|
||||
C_INFTYP = ValReal( 1.0/0.0);
|
||||
C_INFTYM = ValReal(-1.0/0.0);
|
||||
|
||||
mul_expbits_0_to_4:packed array[0..31]of ValReal=(
|
||||
1E0, 1E1, 1E2, 1E3,
|
||||
1E4, 1E5, 1E6, 1E7,
|
||||
1E8, 1E9, 1E10, 1E11,
|
||||
1E12, 1E13, 1E14, 1E15,
|
||||
1E16, 1E17, 1E18, 1E19,
|
||||
1E20, 1E21, 1E22, 1E23,
|
||||
1E24, 1E25, 1E26, 1E27,
|
||||
1E28, 1E29, 1E30, 1E31);
|
||||
|
||||
{$IF DECLARED(C_HIGH_EXPBITS_5TO8)}
|
||||
mul_expbits_5_to_8:packed array[1..C_HIGH_EXPBITS_5TO8] of ValReal=(
|
||||
1E32, 1E64, 1E96, 1E128,
|
||||
1E160, 1E192, 1E224, 1E256, 1E288
|
||||
{$IF DECLARED(C_HIGH_EXPBITS_9ANDUP)},
|
||||
1E320, 1E352, 1E384, 1E416, 1E448, 1E480
|
||||
{$ENDIF});
|
||||
{$ELSE}
|
||||
mul_expbits_5_to_8:ValReal=1E32;
|
||||
{$ENDIF}
|
||||
|
||||
{$IF DECLARED(C_HIGH_EXPBITS_9ANDUP)}
|
||||
mul_expbits_9_and_up:packed array[1..C_HIGH_EXPBITS_9ANDUP] of ValReal=(
|
||||
1E512, 1E1024, 1E1536, 1E2048,
|
||||
1E2560, 1E3072, 1E3584, 1E4096,
|
||||
1E4608);
|
||||
{$ENDIF}
|
||||
|
||||
begin
|
||||
if power=0 then mul_by_power10:=x else
|
||||
if power<-C_MAX_POWER then mul_by_power10:=0 else
|
||||
if power>C_MAX_POWER then
|
||||
if x<0 then mul_by_power10:=C_INFTYM else
|
||||
if x>0 then mul_by_power10:=C_INFTYP else mul_by_power10:=0
|
||||
else
|
||||
if power<0 then
|
||||
begin
|
||||
power:=-power;
|
||||
mul_by_power10:=x/mul_expbits_0_to_4[power and $1F];
|
||||
power:=(power shr 5);
|
||||
if power=0 then exit;
|
||||
{$IF DECLARED(C_HIGH_EXPBITS_5TO8)}
|
||||
if power and $F<>0 then
|
||||
mul_by_power10:=
|
||||
mul_by_power10/mul_expbits_5_to_8[power and $F];
|
||||
{$ELSE} // "single", power<>0, so always div
|
||||
mul_by_power10:=mul_by_power10/mul_expbits_5_to_8;
|
||||
{$ENDIF}
|
||||
{$IF DECLARED(C_HIGH_EXPBITS_9ANDUP)}
|
||||
power:=(power shr 4);
|
||||
if power<>0 then
|
||||
mul_by_power10:=
|
||||
mul_by_power10/mul_expbits_9_and_up[power];
|
||||
{$ENDIF}
|
||||
end
|
||||
else
|
||||
begin
|
||||
mul_by_power10:=x*mul_expbits_0_to_4[power and $1F];
|
||||
power:=(power shr 5);
|
||||
if power=0 then exit;
|
||||
{$IF DECLARED(C_HIGH_EXPBITS_5TO8)}
|
||||
if power and $F<>0 then
|
||||
mul_by_power10:=
|
||||
mul_by_power10*mul_expbits_5_to_8[power and $F];
|
||||
{$ELSE} // "single", power<>0, so always mul
|
||||
mul_by_power10:=mul_by_power10*mul_expbits_5_to_8;
|
||||
{$ENDIF}
|
||||
{$IF DECLARED(C_HIGH_EXPBITS_9ANDUP)}
|
||||
power:=(power shr 4);
|
||||
if power<>0 then
|
||||
mul_by_power10:=
|
||||
mul_by_power10*mul_expbits_9_and_up[power];
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
|
||||
Function fpc_Val_Real_ShortStr(const s : shortstring; out Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_SHORTSTR']; compilerproc;
|
||||
var
|
||||
hd,
|
||||
sign : valreal;
|
||||
esign,
|
||||
exponent,
|
||||
expstart,
|
||||
decpoint : SizeInt;
|
||||
nint,
|
||||
nlz,
|
||||
explimit,
|
||||
explastdigit: SizeInt;
|
||||
begin
|
||||
fpc_Val_Real_ShortStr:=0.0;
|
||||
code:=1;
|
||||
exponent:=0;
|
||||
decpoint:=0;
|
||||
esign:=1;
|
||||
hd:=0.0;
|
||||
nlz:=0;
|
||||
nint:=0;
|
||||
sign:=1;
|
||||
while (code<=length(s)) and (s[code] in [' ',#9]) do
|
||||
inc(code);
|
||||
if code<=length(s) then
|
||||
case s[code] of
|
||||
'+' : inc(code);
|
||||
'-' : begin
|
||||
sign:=-1;
|
||||
inc(code);
|
||||
end;
|
||||
end;
|
||||
{ leading zeroes do not influence result, skip all but one of them }
|
||||
expstart:=code;
|
||||
while (code<Length(s)) and (s[code]='0') do
|
||||
inc(code);
|
||||
if (code>expstart) then
|
||||
dec(code);
|
||||
expstart:=code;
|
||||
while (Code<=Length(s)) do
|
||||
begin
|
||||
case s[code] of
|
||||
'0':
|
||||
begin
|
||||
if (hd=0) then
|
||||
inc(nlz,ord(decpoint<>0))
|
||||
else
|
||||
inc(nint,ord(decpoint=0));
|
||||
hd:=hd*10;
|
||||
end;
|
||||
'1'..'9':
|
||||
begin
|
||||
if (decpoint=0) then
|
||||
inc(nint);
|
||||
hd:=hd*10+(ord(s[code])-ord('0'));
|
||||
end;
|
||||
'.':
|
||||
if decpoint=0 then
|
||||
decpoint:=code
|
||||
else
|
||||
exit;
|
||||
else
|
||||
break;
|
||||
end;
|
||||
inc(code);
|
||||
end;
|
||||
{ must have seen at least one digit }
|
||||
if (code-expstart)<1+ord(decpoint<>0) then
|
||||
exit;
|
||||
|
||||
if decpoint<>0 then
|
||||
decpoint:=code-decpoint-1;
|
||||
|
||||
{ Exponent ? }
|
||||
if (length(s)>=code) and (s[code] in ['e','E']) then
|
||||
begin
|
||||
inc(code);
|
||||
if Length(s) >= code then
|
||||
case s[code] of
|
||||
'+': inc(code);
|
||||
'-': begin
|
||||
esign:=-1;
|
||||
inc(code);
|
||||
end;
|
||||
end;
|
||||
expstart:=code;
|
||||
{ Limit the exponent, accounting for digits in integer part of mantissa
|
||||
and leading zeros in fractional part, e.g 100.0e306 = 1.0e308, etc. }
|
||||
if (esign<0) then
|
||||
explimit:=valmaxexpnorm+mantissabits-1+nint
|
||||
else if (nint>0) then
|
||||
explimit:=valmaxexpnorm+1-nint
|
||||
else
|
||||
explimit:=valmaxexpnorm+1+nlz;
|
||||
explastdigit:=(explimit mod 10)+ord('0');
|
||||
explimit:=explimit div 10;
|
||||
while (length(s)>=code) and (s[code] in ['0'..'9']) do
|
||||
begin
|
||||
{ Check commented out: since this code is used by compiler, it would error out
|
||||
e.g. if compiling '1e3000' for non-x86 target. OTOH silently treating it
|
||||
as infinity isn't a good option either. }
|
||||
(*
|
||||
if (exponent>explimit) or
|
||||
((exponent=explimit) and (ord(s[code])>explastdigit)) then
|
||||
begin
|
||||
{ ignore exponent overflow for zero mantissa }
|
||||
if hd<>0.0 then
|
||||
exit;
|
||||
end
|
||||
else *)
|
||||
exponent:=exponent*10+(ord(s[code])-ord('0'));
|
||||
inc(code);
|
||||
end;
|
||||
if code=expstart then
|
||||
exit;
|
||||
end;
|
||||
{ Not all characters are read ? }
|
||||
if length(s)>=code then
|
||||
exit;
|
||||
|
||||
{ adjust exponent based on decimal point }
|
||||
dec(exponent,decpoint*esign);
|
||||
if (exponent<0) then
|
||||
begin
|
||||
esign:=-1;
|
||||
exponent:=-exponent;
|
||||
end;
|
||||
|
||||
{ evaluate sign }
|
||||
{ (before exponent, because the exponent may turn it into a denormal) }
|
||||
fpc_Val_Real_ShortStr:=hd*sign;
|
||||
|
||||
{ Calculate Exponent }
|
||||
hd:=1.0;
|
||||
{ the magnitude range maximum (normal) is lower in absolute value than the }
|
||||
{ the magnitude range minimum (denormal). E.g. an extended value can go }
|
||||
{ up to 1E4932, but "down" to 1E-4951. So make sure that we don't try to }
|
||||
{ calculate 1E4951 as factor, since that would overflow and result in 0. }
|
||||
if (exponent>valmaxexpnorm-2) then
|
||||
begin
|
||||
hd:=mul_by_power10(hd,valmaxexpnorm-2);
|
||||
if esign>0 then
|
||||
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr*hd
|
||||
else
|
||||
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr/hd;
|
||||
dec(exponent,valmaxexpnorm-2);
|
||||
hd:=1.0;
|
||||
end;
|
||||
hd:=mul_by_power10(hd,exponent);
|
||||
|
||||
if esign>0 then
|
||||
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr*hd
|
||||
else
|
||||
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr/hd;
|
||||
|
||||
{ success ! }
|
||||
code:=0;
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
{$else not FLOAT_ASCII_FALLBACK}
|
||||
|
||||
{$ifndef FPUNONE}
|
||||
Function fpc_Val_Real_ShortStr(const s : shortstring; out Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_SHORTSTR']; compilerproc;
|
||||
begin
|
||||
@ -1916,8 +1569,6 @@ begin
|
||||
end;
|
||||
{$endif FPUNONE}
|
||||
|
||||
{$endif FLOAT_ASCII_FALLBACK}
|
||||
|
||||
{$ifndef FPC_STR_ENUM_INTERN}
|
||||
function fpc_val_enum_shortstr(str2ordindex:pointer;const s:shortstring;out code:valsint):longint; [public, alias:'FPC_VAL_ENUM_SHORTSTR']; compilerproc;
|
||||
|
||||
|
||||
@ -117,9 +117,6 @@ Type
|
||||
Real = type Double;
|
||||
{$endif}
|
||||
|
||||
{ Can be individually defined/undefined on a per-platform basis }
|
||||
{ define FLOAT_ASCII_FALLBACK}
|
||||
|
||||
{$ifdef CPUI386}
|
||||
{$define CPU32}
|
||||
|
||||
|
||||
@ -86,9 +86,6 @@ Type
|
||||
Real = type Double;
|
||||
{$endif}
|
||||
|
||||
{ Can be individually defined/undefined on a per-platform basis }
|
||||
{ define FLOAT_ASCII_FALLBACK}
|
||||
|
||||
{$ifdef CPUI386}
|
||||
{$define CPU32}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user