------------------------------------------------------------------------------ | |

-- -- | |

-- GNAT RUN-TIME COMPONENTS -- | |

-- -- | |

-- S Y S T E M . I M A G E _ R -- | |

-- -- | |

-- B o d y -- | |

-- -- | |

-- Copyright (C) 1992-2021, 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.Double_Real; | |

with System.Float_Control; | |

with System.Img_Util; use System.Img_Util; | |

package body System.Image_R is | |

-- The following defines the maximum number of digits that we can convert | |

-- accurately. This is limited by the precision of the Num type, and also | |

-- by the number of digits that can be held in the Uns type, which is the | |

-- integer type we use as an intermediate in the computation. But, in both | |

-- cases, we can work with a double value in these types. | |

-- Note that in the following, the "-2" accounts for the space and one | |

-- extra digit, since we need the maximum number of 9's that can be | |

-- represented, e.g. for the 64-bit case, Long_Long_Unsigned'Width is | |

-- 21, since the maximum value (approx 1.8E+19) has 20 digits, but the | |

-- maximum number of 9's that can be represented is only 19. | |

Maxdigs : constant Natural := 2 * Natural'Min (Uns'Width - 2, Num'Digits); | |

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 | |

package Double_Real is new System.Double_Real (Num); | |

use type Double_Real.Double_T; | |

subtype Double_T is Double_Real.Double_T; | |

-- The double floating-point type | |

function From_Unsigned is new Double_Real.From_Unsigned (Uns); | |

function To_Unsigned is new Double_Real.To_Unsigned (Uns); | |

-- Convert betwwen a double Num and a single Uns | |

function Is_Negative (V : Num) return Boolean; | |

-- Return True if V is negative for the purpose of the output, i.e. return | |

-- True for negative zeros only if Signed_Zeros is True. | |

----------------------- | |

-- Image_Fixed_Point -- | |

----------------------- | |

procedure Image_Fixed_Point | |

(V : Num; | |

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_Fixed_Point; | |

-------------------------- | |

-- Image_Floating_Point -- | |

-------------------------- | |

procedure Image_Floating_Point | |

(V : Num; | |

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 zeros. For negative zeros, we generate a | |

-- blank only if Signed_Zeros is False (the RM only permits the | |

-- output of -0.0 when Signed_Zeros is True). We do not generate | |

-- a blank for positive infinity, since we output an explicit +. | |

if not Is_Negative (V) and then V <= Num'Last then | |

pragma Annotate (CodePeer, False_Positive, "condition predetermined", | |

"CodePeer analysis ignores NaN and Inf values"); | |

pragma Assert (S'Last > 1); | |

-- The caller is responsible for S to be large enough for all | |

-- Image_Floating_Point operation. | |

S (1) := ' '; | |

P := 1; | |

else | |

P := 0; | |

end if; | |

Set_Image_Real (V, S, P, 1, Digs - 1, 3); | |

end Image_Floating_Point; | |

----------------- | |

-- Is_Negative -- | |

----------------- | |

function Is_Negative (V : Num) return Boolean is | |

begin | |

if V < 0.0 then | |

return True; | |

elsif V > 0.0 then | |

return False; | |

elsif not Num'Signed_Zeros then | |

return False; | |

else | |

return Num'Copy_Sign (1.0, V) < 0.0; | |

end if; | |

end Is_Negative; | |

-------------------- | |

-- Set_Image_Real -- | |

-------------------- | |

procedure Set_Image_Real | |

(V : Num; | |

S : in out String; | |

P : in out Natural; | |

Fore : Natural; | |

Aft : Natural; | |

Exp : Natural) | |

is | |

Powten : constant array (0 .. Maxpow) of Double_T; | |

pragma Import (Ada, Powten); | |

for Powten'Address use Powten_Address; | |

NFrac : constant Natural := Natural'Max (Aft, 1); | |

-- Number of digits after the decimal point | |

Digs : String (1 .. 3 + Maxdigs); | |

-- Array used to hold digits of converted integer value | |

Ndigs : Natural; | |

-- Number of digits stored in Digs (and also subscript of last digit) | |

Scale : Integer := 0; | |

-- Exponent such that the result is Digs (1 .. NDigs) * 10**(-Scale) | |

X : Double_T; | |

-- Current absolute value of the input after scaling | |

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. 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 multiplication by | |

-- 10.0 and one is subtracted for each division by 10.0. | |

------------------ | |

-- Adjust_Scale -- | |

------------------ | |

procedure Adjust_Scale (S : Natural) is | |

Lo, Mid, Hi : Natural; | |

XP : Double_T; | |

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; | |

end Adjust_Scale; | |

-- Start of processing for Set_Image_Real | |

begin | |

-- We call the floating-point processor reset routine so we can be sure | |

-- that the processor is properly set for conversions. This is notably | |

-- needed on Windows, where calls to the operating system randomly reset | |

-- the processor into 64-bit mode. | |

if Num'Machine_Mantissa = 64 then | |

System.Float_Control.Reset; | |

end if; | |

-- 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 two tests succeed, then we definitely have | |

-- an infinite value, so we print +Inf or -Inf. | |

if V > Num'Last then | |

pragma Annotate (CodePeer, False_Positive, "dead code", | |

"CodePeer analysis ignores NaN and Inf values"); | |

pragma Annotate (CodePeer, False_Positive, "test always true", | |

"CodePeer analysis ignores NaN and Inf values"); | |

Set_Floating_Invalid_Value (Infinity, S, P, Fore, Aft, Exp); | |

elsif V < Num'First then | |

Set_Floating_Invalid_Value (Minus_Infinity, S, P, Fore, Aft, Exp); | |

-- In all other cases we print NaN | |

else | |

Set_Floating_Invalid_Value (Not_A_Number, S, P, Fore, Aft, Exp); | |

end if; | |

return; | |

end if; | |

-- Set the first character like Image | |

Digs (1) := (if Is_Negative (V) then '-' else ' '); | |

Ndigs := 1; | |

X := Double_Real.To_Double (abs (V)); | |

-- If X is zero, we are done | |

if X = 0.0 then | |

Digs (2) := '0'; | |

Ndigs := 2; | |

-- Otherwise, scale X and convert it to an integer | |

else | |

-- In exponent notation, we need exactly NFrac + 1 digits and always | |

-- round the last one. | |

if Exp > 0 then | |

Adjust_Scale (Natural'Min (NFrac + 1, Maxdigs)); | |

X := X + 0.5; | |

-- In straight notation, we compute the maximum number of digits and | |

-- compare how many of them will be put after the decimal point with | |

-- Nfrac, in order to find out whether we need to round the last one | |

-- here or whether the rounding is performed by Set_Decimal_Digits. | |

else | |

Adjust_Scale (Maxdigs); | |

if Scale <= NFrac then | |

X := X + 0.5; | |

end if; | |

end if; | |

-- If X fits in an Uns, do the conversion directly. Note that this is | |

-- always the case for the Image attribute. | |

if X <= Num (Uns'Last) then | |

Set_Image_Unsigned (To_Unsigned (X), Digs, Ndigs); | |

-- Otherwise, do the conversion in two steps | |

else pragma Assert (X <= 10.0 ** Num'Digits * Num (Uns'Last)); | |

declare | |

Y : constant Uns := To_Unsigned (X / Powten (Num'Digits)); | |

Buf : String (1 .. Num'Digits); | |

Len : Natural; | |

begin | |

Set_Image_Unsigned (Y, Digs, Ndigs); | |

X := X - From_Unsigned (Y) * Powten (Num'Digits); | |

Len := 0; | |

Set_Image_Unsigned (To_Unsigned (X), Buf, Len); | |

for J in 1 .. Num'Digits - Len loop | |

Digs (Ndigs + J) := '0'; | |

end loop; | |

for J in 1 .. Len loop | |

Digs (Ndigs + Num'Digits - Len + J) := Buf (J); | |

end loop; | |

Ndigs := Ndigs + Num'Digits; | |

end; | |

end if; | |

end if; | |

Set_Decimal_Digits (Digs, Ndigs, S, P, Scale, Fore, Aft, Exp); | |

end Set_Image_Real; | |

end System.Image_R; |