700 lines
22 KiB
Ada
700 lines
22 KiB
Ada
|
------------------------------------------------------------------------------
|
||
|
|
-- --
|
||
|
|
-- GNAT RUN-TIME COMPONENTS --
|
||
|
|
-- --
|
||
|
|
-- S Y S T E M . I M G _ R E A L --
|
||
|
|
-- --
|
||
|
|
-- B o d y --
|
||
|
|
-- --
|
||
|
|
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
|
||
|
|
-- --
|
||
|
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||
|
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||
|
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||
|
|
-- --
|
||
|
|
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||
|
|
-- additional permissions described in the GCC Runtime Library Exception, --
|
||
|
|
-- version 3.1, as published by the Free Software Foundation. --
|
||
|
|
-- --
|
||
|
|
-- You should have received a copy of the GNU General Public License and --
|
||
|
|
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||
|
|
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||
|
|
-- <http://www.gnu.org/licenses/>. --
|
||
|
|
-- --
|
||
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
||
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||
|
|
-- --
|
||
|
|
------------------------------------------------------------------------------
|
||
|
|
|
||
|
|
with System.Img_LLU; use System.Img_LLU;
|
||
|
|
with System.Img_Uns; use System.Img_Uns;
|
||
|
|
with System.Powten_Table; use System.Powten_Table;
|
||
|
|
with System.Unsigned_Types; use System.Unsigned_Types;
|
||
|
|
with System.Float_Control;
|
||
|
|
|
||
|
|
package body System.Img_Real is
|
||
|
|
|
||
|
|
-- The following defines the maximum number of digits that we can convert
|
||
|
|
-- accurately. This is limited by the precision of Long_Long_Float, and
|
||
|
|
-- also by the number of digits we can hold in Long_Long_Unsigned, which
|
||
|
|
-- is the integer type we use as an intermediate for the result.
|
||
|
|
|
||
|
|
-- We assume that in practice, the limitation will come from the digits
|
||
|
|
-- value, rather than the integer value. This is true for typical IEEE
|
||
|
|
-- implementations, and at worst, the only loss is for some precision
|
||
|
|
-- in very high precision floating-point output.
|
||
|
|
|
||
|
|
-- Note that in the following, the "-2" accounts for the sign and one
|
||
|
|
-- extra digits, since we need the maximum number of 9's that can be
|
||
|
|
-- supported, e.g. for the normal 64 bit case, Long_Long_Integer'Width
|
||
|
|
-- is 21, since the maximum value (approx 1.6 * 10**19) has 20 digits,
|
||
|
|
-- but the maximum number of 9's that can be supported is 19.
|
||
|
|
|
||
|
|
Maxdigs : constant :=
|
||
|
|
Natural'Min
|
||
|
|
(Long_Long_Unsigned'Width - 2, Long_Long_Float'Digits);
|
||
|
|
|
||
|
|
Unsdigs : constant := Unsigned'Width - 2;
|
||
|
|
-- Number of digits that can be converted using type Unsigned
|
||
|
|
-- See above for the explanation of the -2.
|
||
|
|
|
||
|
|
Maxscaling : constant := 5000;
|
||
|
|
-- Max decimal scaling required during conversion of floating-point
|
||
|
|
-- numbers to decimal. This is used to defend against infinite
|
||
|
|
-- looping in the conversion, as can be caused by erroneous executions.
|
||
|
|
-- The largest exponent used on any current system is 2**16383, which
|
||
|
|
-- is approximately 10**4932, and the highest number of decimal digits
|
||
|
|
-- is about 35 for 128-bit floating-point formats, so 5000 leaves
|
||
|
|
-- enough room for scaling such values
|
||
|
|
|
||
|
|
function Is_Negative (V : Long_Long_Float) return Boolean;
|
||
|
|
pragma Import (Intrinsic, Is_Negative);
|
||
|
|
|
||
|
|
--------------------------
|
||
|
|
-- Image_Floating_Point --
|
||
|
|
--------------------------
|
||
|
|
|
||
|
|
procedure Image_Floating_Point
|
||
|
|
(V : Long_Long_Float;
|
||
|
|
S : in out String;
|
||
|
|
P : out Natural;
|
||
|
|
Digs : Natural)
|
||
|
|
is
|
||
|
|
pragma Assert (S'First = 1);
|
||
|
|
|
||
|
|
begin
|
||
|
|
-- Decide whether a blank should be prepended before the call to
|
||
|
|
-- Set_Image_Real. We generate a blank for positive values, and
|
||
|
|
-- also for positive zeroes. For negative zeroes, we generate a
|
||
|
|
-- space only if Signed_Zeroes is True (the RM only permits the
|
||
|
|
-- output of -0.0 on targets where this is the case). We can of
|
||
|
|
-- course still see a -0.0 on a target where Signed_Zeroes is
|
||
|
|
-- False (since this attribute refers to the proper handling of
|
||
|
|
-- negative zeroes, not to their existence). We do not generate
|
||
|
|
-- a blank for positive infinity, since we output an explicit +.
|
||
|
|
|
||
|
|
if (not Is_Negative (V) and then V <= Long_Long_Float'Last)
|
||
|
|
or else (not Long_Long_Float'Signed_Zeros and then V = -0.0)
|
||
|
|
then
|
||
|
|
S (1) := ' ';
|
||
|
|
P := 1;
|
||
|
|
else
|
||
|
|
P := 0;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
Set_Image_Real (V, S, P, 1, Digs - 1, 3);
|
||
|
|
end Image_Floating_Point;
|
||
|
|
|
||
|
|
--------------------------------
|
||
|
|
-- Image_Ordinary_Fixed_Point --
|
||
|
|
--------------------------------
|
||
|
|
|
||
|
|
procedure Image_Ordinary_Fixed_Point
|
||
|
|
(V : Long_Long_Float;
|
||
|
|
S : in out String;
|
||
|
|
P : out Natural;
|
||
|
|
Aft : Natural)
|
||
|
|
is
|
||
|
|
pragma Assert (S'First = 1);
|
||
|
|
|
||
|
|
begin
|
||
|
|
-- Output space at start if non-negative
|
||
|
|
|
||
|
|
if V >= 0.0 then
|
||
|
|
S (1) := ' ';
|
||
|
|
P := 1;
|
||
|
|
else
|
||
|
|
P := 0;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
Set_Image_Real (V, S, P, 1, Aft, 0);
|
||
|
|
end Image_Ordinary_Fixed_Point;
|
||
|
|
|
||
|
|
--------------------
|
||
|
|
-- Set_Image_Real --
|
||
|
|
--------------------
|
||
|
|
|
||
|
|
procedure Set_Image_Real
|
||
|
|
(V : Long_Long_Float;
|
||
|
|
S : out String;
|
||
|
|
P : in out Natural;
|
||
|
|
Fore : Natural;
|
||
|
|
Aft : Natural;
|
||
|
|
Exp : Natural)
|
||
|
|
is
|
||
|
|
NFrac : constant Natural := Natural'Max (Aft, 1);
|
||
|
|
Sign : Character;
|
||
|
|
X : Long_Long_Float;
|
||
|
|
Scale : Integer;
|
||
|
|
Expon : Integer;
|
||
|
|
|
||
|
|
Field_Max : constant := 255;
|
||
|
|
-- This should be the same value as Ada.[Wide_]Text_IO.Field'Last.
|
||
|
|
-- It is not worth dragging in Ada.Text_IO to pick up this value,
|
||
|
|
-- since it really should never be necessary to change it.
|
||
|
|
|
||
|
|
Digs : String (1 .. 2 * Field_Max + 16);
|
||
|
|
-- Array used to hold digits of converted integer value. This is a
|
||
|
|
-- large enough buffer to accommodate ludicrous values of Fore and Aft.
|
||
|
|
|
||
|
|
Ndigs : Natural;
|
||
|
|
-- Number of digits stored in Digs (and also subscript of last digit)
|
||
|
|
|
||
|
|
procedure Adjust_Scale (S : Natural);
|
||
|
|
-- Adjusts the value in X by multiplying or dividing by a power of
|
||
|
|
-- ten so that it is in the range 10**(S-1) <= X < 10**S. Includes
|
||
|
|
-- adding 0.5 to round the result, readjusting if the rounding causes
|
||
|
|
-- the result to wander out of the range. Scale is adjusted to reflect
|
||
|
|
-- the power of ten used to divide the result (i.e. one is added to
|
||
|
|
-- the scale value for each division by 10.0, or one is subtracted
|
||
|
|
-- for each multiplication by 10.0).
|
||
|
|
|
||
|
|
procedure Convert_Integer;
|
||
|
|
-- Takes the value in X, outputs integer digits into Digs. On return,
|
||
|
|
-- Ndigs is set to the number of digits stored. The digits are stored
|
||
|
|
-- in Digs (1 .. Ndigs),
|
||
|
|
|
||
|
|
procedure Set (C : Character);
|
||
|
|
-- Sets character C in output buffer
|
||
|
|
|
||
|
|
procedure Set_Blanks_And_Sign (N : Integer);
|
||
|
|
-- Sets leading blanks and minus sign if needed. N is the number of
|
||
|
|
-- positions to be filled (a minus sign is output even if N is zero
|
||
|
|
-- or negative, but for a positive value, if N is non-positive, then
|
||
|
|
-- the call has no effect).
|
||
|
|
|
||
|
|
procedure Set_Digs (S, E : Natural);
|
||
|
|
-- Set digits S through E from Digs buffer. No effect if S > E
|
||
|
|
|
||
|
|
procedure Set_Special_Fill (N : Natural);
|
||
|
|
-- After outputting +Inf, -Inf or NaN, this routine fills out the
|
||
|
|
-- rest of the field with * characters. The argument is the number
|
||
|
|
-- of characters output so far (either 3 or 4)
|
||
|
|
|
||
|
|
procedure Set_Zeros (N : Integer);
|
||
|
|
-- Set N zeros, no effect if N is negative
|
||
|
|
|
||
|
|
pragma Inline (Set);
|
||
|
|
pragma Inline (Set_Digs);
|
||
|
|
pragma Inline (Set_Zeros);
|
||
|
|
|
||
|
|
------------------
|
||
|
|
-- Adjust_Scale --
|
||
|
|
------------------
|
||
|
|
|
||
|
|
procedure Adjust_Scale (S : Natural) is
|
||
|
|
Lo : Natural;
|
||
|
|
Hi : Natural;
|
||
|
|
Mid : Natural;
|
||
|
|
XP : Long_Long_Float;
|
||
|
|
|
||
|
|
begin
|
||
|
|
-- Cases where scaling up is required
|
||
|
|
|
||
|
|
if X < Powten (S - 1) then
|
||
|
|
|
||
|
|
-- What we are looking for is a power of ten to multiply X by
|
||
|
|
-- so that the result lies within the required range.
|
||
|
|
|
||
|
|
loop
|
||
|
|
XP := X * Powten (Maxpow);
|
||
|
|
exit when XP >= Powten (S - 1) or else Scale < -Maxscaling;
|
||
|
|
X := XP;
|
||
|
|
Scale := Scale - Maxpow;
|
||
|
|
end loop;
|
||
|
|
|
||
|
|
-- The following exception is only raised in case of erroneous
|
||
|
|
-- execution, where a number was considered valid but still
|
||
|
|
-- fails to scale up. One situation where this can happen is
|
||
|
|
-- when a system which is supposed to be IEEE-compliant, but
|
||
|
|
-- has been reconfigured to flush denormals to zero.
|
||
|
|
|
||
|
|
if Scale < -Maxscaling then
|
||
|
|
raise Constraint_Error;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
-- Here we know that we must multiply by at least 10**1 and that
|
||
|
|
-- 10**Maxpow takes us too far: binary search to find right one.
|
||
|
|
|
||
|
|
-- Because of roundoff errors, it is possible for the value
|
||
|
|
-- of XP to be just outside of the interval when Lo >= Hi. In
|
||
|
|
-- that case we adjust explicitly by a factor of 10. This
|
||
|
|
-- can only happen with a value that is very close to an
|
||
|
|
-- exact power of 10.
|
||
|
|
|
||
|
|
Lo := 1;
|
||
|
|
Hi := Maxpow;
|
||
|
|
|
||
|
|
loop
|
||
|
|
Mid := (Lo + Hi) / 2;
|
||
|
|
XP := X * Powten (Mid);
|
||
|
|
|
||
|
|
if XP < Powten (S - 1) then
|
||
|
|
|
||
|
|
if Lo >= Hi then
|
||
|
|
Mid := Mid + 1;
|
||
|
|
XP := XP * 10.0;
|
||
|
|
exit;
|
||
|
|
|
||
|
|
else
|
||
|
|
Lo := Mid + 1;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
elsif XP >= Powten (S) then
|
||
|
|
|
||
|
|
if Lo >= Hi then
|
||
|
|
Mid := Mid - 1;
|
||
|
|
XP := XP / 10.0;
|
||
|
|
exit;
|
||
|
|
|
||
|
|
else
|
||
|
|
Hi := Mid - 1;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
else
|
||
|
|
exit;
|
||
|
|
end if;
|
||
|
|
end loop;
|
||
|
|
|
||
|
|
X := XP;
|
||
|
|
Scale := Scale - Mid;
|
||
|
|
|
||
|
|
-- Cases where scaling down is required
|
||
|
|
|
||
|
|
elsif X >= Powten (S) then
|
||
|
|
|
||
|
|
-- What we are looking for is a power of ten to divide X by
|
||
|
|
-- so that the result lies within the required range.
|
||
|
|
|
||
|
|
loop
|
||
|
|
XP := X / Powten (Maxpow);
|
||
|
|
exit when XP < Powten (S) or else Scale > Maxscaling;
|
||
|
|
X := XP;
|
||
|
|
Scale := Scale + Maxpow;
|
||
|
|
end loop;
|
||
|
|
|
||
|
|
-- The following exception is only raised in case of erroneous
|
||
|
|
-- execution, where a number was considered valid but still
|
||
|
|
-- fails to scale up. One situation where this can happen is
|
||
|
|
-- when a system which is supposed to be IEEE-compliant, but
|
||
|
|
-- has been reconfigured to flush denormals to zero.
|
||
|
|
|
||
|
|
if Scale > Maxscaling then
|
||
|
|
raise Constraint_Error;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
-- Here we know that we must divide by at least 10**1 and that
|
||
|
|
-- 10**Maxpow takes us too far, binary search to find right one.
|
||
|
|
|
||
|
|
Lo := 1;
|
||
|
|
Hi := Maxpow;
|
||
|
|
|
||
|
|
loop
|
||
|
|
Mid := (Lo + Hi) / 2;
|
||
|
|
XP := X / Powten (Mid);
|
||
|
|
|
||
|
|
if XP < Powten (S - 1) then
|
||
|
|
|
||
|
|
if Lo >= Hi then
|
||
|
|
XP := XP * 10.0;
|
||
|
|
Mid := Mid - 1;
|
||
|
|
exit;
|
||
|
|
|
||
|
|
else
|
||
|
|
Hi := Mid - 1;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
elsif XP >= Powten (S) then
|
||
|
|
|
||
|
|
if Lo >= Hi then
|
||
|
|
XP := XP / 10.0;
|
||
|
|
Mid := Mid + 1;
|
||
|
|
exit;
|
||
|
|
|
||
|
|
else
|
||
|
|
Lo := Mid + 1;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
else
|
||
|
|
exit;
|
||
|
|
end if;
|
||
|
|
end loop;
|
||
|
|
|
||
|
|
X := XP;
|
||
|
|
Scale := Scale + Mid;
|
||
|
|
|
||
|
|
-- Here we are already scaled right
|
||
|
|
|
||
|
|
else
|
||
|
|
null;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
-- Round, readjusting scale if needed. Note that if a readjustment
|
||
|
|
-- occurs, then it is never necessary to round again, because there
|
||
|
|
-- is no possibility of such a second rounding causing a change.
|
||
|
|
|
||
|
|
X := X + 0.5;
|
||
|
|
|
||
|
|
if X >= Powten (S) then
|
||
|
|
X := X / 10.0;
|
||
|
|
Scale := Scale + 1;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
end Adjust_Scale;
|
||
|
|
|
||
|
|
---------------------
|
||
|
|
-- Convert_Integer --
|
||
|
|
---------------------
|
||
|
|
|
||
|
|
procedure Convert_Integer is
|
||
|
|
begin
|
||
|
|
-- Use Unsigned routine if possible, since on many machines it will
|
||
|
|
-- be significantly more efficient than the Long_Long_Unsigned one.
|
||
|
|
|
||
|
|
if X < Powten (Unsdigs) then
|
||
|
|
Ndigs := 0;
|
||
|
|
Set_Image_Unsigned
|
||
|
|
(Unsigned (Long_Long_Float'Truncation (X)),
|
||
|
|
Digs, Ndigs);
|
||
|
|
|
||
|
|
-- But if we want more digits than fit in Unsigned, we have to use
|
||
|
|
-- the Long_Long_Unsigned routine after all.
|
||
|
|
|
||
|
|
else
|
||
|
|
Ndigs := 0;
|
||
|
|
Set_Image_Long_Long_Unsigned
|
||
|
|
(Long_Long_Unsigned (Long_Long_Float'Truncation (X)),
|
||
|
|
Digs, Ndigs);
|
||
|
|
end if;
|
||
|
|
end Convert_Integer;
|
||
|
|
|
||
|
|
---------
|
||
|
|
-- Set --
|
||
|
|
---------
|
||
|
|
|
||
|
|
procedure Set (C : Character) is
|
||
|
|
begin
|
||
|
|
P := P + 1;
|
||
|
|
S (P) := C;
|
||
|
|
end Set;
|
||
|
|
|
||
|
|
-------------------------
|
||
|
|
-- Set_Blanks_And_Sign --
|
||
|
|
-------------------------
|
||
|
|
|
||
|
|
procedure Set_Blanks_And_Sign (N : Integer) is
|
||
|
|
begin
|
||
|
|
if Sign = '-' then
|
||
|
|
for J in 1 .. N - 1 loop
|
||
|
|
Set (' ');
|
||
|
|
end loop;
|
||
|
|
|
||
|
|
Set ('-');
|
||
|
|
|
||
|
|
else
|
||
|
|
for J in 1 .. N loop
|
||
|
|
Set (' ');
|
||
|
|
end loop;
|
||
|
|
end if;
|
||
|
|
end Set_Blanks_And_Sign;
|
||
|
|
|
||
|
|
--------------
|
||
|
|
-- Set_Digs --
|
||
|
|
--------------
|
||
|
|
|
||
|
|
procedure Set_Digs (S, E : Natural) is
|
||
|
|
begin
|
||
|
|
for J in S .. E loop
|
||
|
|
Set (Digs (J));
|
||
|
|
end loop;
|
||
|
|
end Set_Digs;
|
||
|
|
|
||
|
|
----------------------
|
||
|
|
-- Set_Special_Fill --
|
||
|
|
----------------------
|
||
|
|
|
||
|
|
procedure Set_Special_Fill (N : Natural) is
|
||
|
|
F : Natural;
|
||
|
|
|
||
|
|
begin
|
||
|
|
F := Fore + 1 + Aft - N;
|
||
|
|
|
||
|
|
if Exp /= 0 then
|
||
|
|
F := F + Exp + 1;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
for J in 1 .. F loop
|
||
|
|
Set ('*');
|
||
|
|
end loop;
|
||
|
|
end Set_Special_Fill;
|
||
|
|
|
||
|
|
---------------
|
||
|
|
-- Set_Zeros --
|
||
|
|
---------------
|
||
|
|
|
||
|
|
procedure Set_Zeros (N : Integer) is
|
||
|
|
begin
|
||
|
|
for J in 1 .. N loop
|
||
|
|
Set ('0');
|
||
|
|
end loop;
|
||
|
|
end Set_Zeros;
|
||
|
|
|
||
|
|
-- Start of processing for Set_Image_Real
|
||
|
|
|
||
|
|
begin
|
||
|
|
-- We call the floating-point processor reset routine so that we can
|
||
|
|
-- be sure the floating-point processor is properly set for conversion
|
||
|
|
-- calls. This is notably need on Windows, where calls to the operating
|
||
|
|
-- system randomly reset the processor into 64-bit mode.
|
||
|
|
|
||
|
|
System.Float_Control.Reset;
|
||
|
|
|
||
|
|
Scale := 0;
|
||
|
|
|
||
|
|
-- Deal with invalid values first,
|
||
|
|
|
||
|
|
if not V'Valid then
|
||
|
|
|
||
|
|
-- Note that we're taking our chances here, as V might be
|
||
|
|
-- an invalid bit pattern resulting from erroneous execution
|
||
|
|
-- (caused by using uninitialized variables for example).
|
||
|
|
|
||
|
|
-- No matter what, we'll at least get reasonable behavior,
|
||
|
|
-- converting to infinity or some other value, or causing an
|
||
|
|
-- exception to be raised is fine.
|
||
|
|
|
||
|
|
-- If the following test succeeds, then we definitely have
|
||
|
|
-- an infinite value, so we print Inf.
|
||
|
|
|
||
|
|
if V > Long_Long_Float'Last then
|
||
|
|
Set ('+');
|
||
|
|
Set ('I');
|
||
|
|
Set ('n');
|
||
|
|
Set ('f');
|
||
|
|
Set_Special_Fill (4);
|
||
|
|
|
||
|
|
-- In all other cases we print NaN
|
||
|
|
|
||
|
|
elsif V < Long_Long_Float'First then
|
||
|
|
Set ('-');
|
||
|
|
Set ('I');
|
||
|
|
Set ('n');
|
||
|
|
Set ('f');
|
||
|
|
Set_Special_Fill (4);
|
||
|
|
|
||
|
|
else
|
||
|
|
Set ('N');
|
||
|
|
Set ('a');
|
||
|
|
Set ('N');
|
||
|
|
Set_Special_Fill (3);
|
||
|
|
end if;
|
||
|
|
|
||
|
|
return;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
-- Positive values
|
||
|
|
|
||
|
|
if V > 0.0 then
|
||
|
|
X := V;
|
||
|
|
Sign := '+';
|
||
|
|
|
||
|
|
-- Negative values
|
||
|
|
|
||
|
|
elsif V < 0.0 then
|
||
|
|
X := -V;
|
||
|
|
Sign := '-';
|
||
|
|
|
||
|
|
-- Zero values
|
||
|
|
|
||
|
|
elsif V = 0.0 then
|
||
|
|
if Long_Long_Float'Signed_Zeros and then Is_Negative (V) then
|
||
|
|
Sign := '-';
|
||
|
|
else
|
||
|
|
Sign := '+';
|
||
|
|
end if;
|
||
|
|
|
||
|
|
Set_Blanks_And_Sign (Fore - 1);
|
||
|
|
Set ('0');
|
||
|
|
Set ('.');
|
||
|
|
Set_Zeros (NFrac);
|
||
|
|
|
||
|
|
if Exp /= 0 then
|
||
|
|
Set ('E');
|
||
|
|
Set ('+');
|
||
|
|
Set_Zeros (Natural'Max (1, Exp - 1));
|
||
|
|
end if;
|
||
|
|
|
||
|
|
return;
|
||
|
|
|
||
|
|
else
|
||
|
|
-- It should not be possible for a NaN to end up here.
|
||
|
|
-- Either the 'Valid test has failed, or we have some form
|
||
|
|
-- of erroneous execution. Raise Constraint_Error instead of
|
||
|
|
-- attempting to go ahead printing the value.
|
||
|
|
|
||
|
|
raise Constraint_Error;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
-- X and Sign are set here, and X is known to be a valid,
|
||
|
|
-- non-zero floating-point number.
|
||
|
|
|
||
|
|
-- Case of non-zero value with Exp = 0
|
||
|
|
|
||
|
|
if Exp = 0 then
|
||
|
|
|
||
|
|
-- First step is to multiply by 10 ** Nfrac to get an integer
|
||
|
|
-- value to be output, an then add 0.5 to round the result.
|
||
|
|
|
||
|
|
declare
|
||
|
|
NF : Natural := NFrac;
|
||
|
|
|
||
|
|
begin
|
||
|
|
loop
|
||
|
|
-- If we are larger than Powten (Maxdigs) now, then
|
||
|
|
-- we have too many significant digits, and we have
|
||
|
|
-- not even finished multiplying by NFrac (NF shows
|
||
|
|
-- the number of unaccounted-for digits).
|
||
|
|
|
||
|
|
if X >= Powten (Maxdigs) then
|
||
|
|
|
||
|
|
-- In this situation, we only to generate a reasonable
|
||
|
|
-- number of significant digits, and then zeroes after.
|
||
|
|
-- So first we rescale to get:
|
||
|
|
|
||
|
|
-- 10 ** (Maxdigs - 1) <= X < 10 ** Maxdigs
|
||
|
|
|
||
|
|
-- and then convert the resulting integer
|
||
|
|
|
||
|
|
Adjust_Scale (Maxdigs);
|
||
|
|
Convert_Integer;
|
||
|
|
|
||
|
|
-- If that caused rescaling, then add zeros to the end
|
||
|
|
-- of the number to account for this scaling. Also add
|
||
|
|
-- zeroes to account for the undone multiplications
|
||
|
|
|
||
|
|
for J in 1 .. Scale + NF loop
|
||
|
|
Ndigs := Ndigs + 1;
|
||
|
|
Digs (Ndigs) := '0';
|
||
|
|
end loop;
|
||
|
|
|
||
|
|
exit;
|
||
|
|
|
||
|
|
-- If multiplication is complete, then convert the resulting
|
||
|
|
-- integer after rounding (note that X is non-negative)
|
||
|
|
|
||
|
|
elsif NF = 0 then
|
||
|
|
X := X + 0.5;
|
||
|
|
Convert_Integer;
|
||
|
|
exit;
|
||
|
|
|
||
|
|
-- Otherwise we can go ahead with the multiplication. If it
|
||
|
|
-- can be done in one step, then do it in one step.
|
||
|
|
|
||
|
|
elsif NF < Maxpow then
|
||
|
|
X := X * Powten (NF);
|
||
|
|
NF := 0;
|
||
|
|
|
||
|
|
-- If it cannot be done in one step, then do partial scaling
|
||
|
|
|
||
|
|
else
|
||
|
|
X := X * Powten (Maxpow);
|
||
|
|
NF := NF - Maxpow;
|
||
|
|
end if;
|
||
|
|
end loop;
|
||
|
|
end;
|
||
|
|
|
||
|
|
-- If number of available digits is less or equal to NFrac,
|
||
|
|
-- then we need an extra zero before the decimal point.
|
||
|
|
|
||
|
|
if Ndigs <= NFrac then
|
||
|
|
Set_Blanks_And_Sign (Fore - 1);
|
||
|
|
Set ('0');
|
||
|
|
Set ('.');
|
||
|
|
Set_Zeros (NFrac - Ndigs);
|
||
|
|
Set_Digs (1, Ndigs);
|
||
|
|
|
||
|
|
-- Normal case with some digits before the decimal point
|
||
|
|
|
||
|
|
else
|
||
|
|
Set_Blanks_And_Sign (Fore - (Ndigs - NFrac));
|
||
|
|
Set_Digs (1, Ndigs - NFrac);
|
||
|
|
Set ('.');
|
||
|
|
Set_Digs (Ndigs - NFrac + 1, Ndigs);
|
||
|
|
end if;
|
||
|
|
|
||
|
|
-- Case of non-zero value with non-zero Exp value
|
||
|
|
|
||
|
|
else
|
||
|
|
-- If NFrac is less than Maxdigs, then all the fraction digits are
|
||
|
|
-- significant, so we can scale the resulting integer accordingly.
|
||
|
|
|
||
|
|
if NFrac < Maxdigs then
|
||
|
|
Adjust_Scale (NFrac + 1);
|
||
|
|
Convert_Integer;
|
||
|
|
|
||
|
|
-- Otherwise, we get the maximum number of digits available
|
||
|
|
|
||
|
|
else
|
||
|
|
Adjust_Scale (Maxdigs);
|
||
|
|
Convert_Integer;
|
||
|
|
|
||
|
|
for J in 1 .. NFrac - Maxdigs + 1 loop
|
||
|
|
Ndigs := Ndigs + 1;
|
||
|
|
Digs (Ndigs) := '0';
|
||
|
|
Scale := Scale - 1;
|
||
|
|
end loop;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
Set_Blanks_And_Sign (Fore - 1);
|
||
|
|
Set (Digs (1));
|
||
|
|
Set ('.');
|
||
|
|
Set_Digs (2, Ndigs);
|
||
|
|
|
||
|
|
-- The exponent is the scaling factor adjusted for the digits
|
||
|
|
-- that we output after the decimal point, since these were
|
||
|
|
-- included in the scaled digits that we output.
|
||
|
|
|
||
|
|
Expon := Scale + NFrac;
|
||
|
|
|
||
|
|
Set ('E');
|
||
|
|
Ndigs := 0;
|
||
|
|
|
||
|
|
if Expon >= 0 then
|
||
|
|
Set ('+');
|
||
|
|
Set_Image_Unsigned (Unsigned (Expon), Digs, Ndigs);
|
||
|
|
else
|
||
|
|
Set ('-');
|
||
|
|
Set_Image_Unsigned (Unsigned (-Expon), Digs, Ndigs);
|
||
|
|
end if;
|
||
|
|
|
||
|
|
Set_Zeros (Exp - Ndigs - 1);
|
||
|
|
Set_Digs (1, Ndigs);
|
||
|
|
end if;
|
||
|
|
|
||
|
|
end Set_Image_Real;
|
||
|
|
|
||
|
|
end System.Img_Real;
|