| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUN-TIME COMPONENTS -- |
| -- -- |
| -- S Y S T E M . I M A G E _ R -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, 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; |
