| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUN-TIME COMPONENTS -- |
| -- -- |
| -- S Y S T E M . I M G _ R E A L -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2014, 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 : aliased Long_Long_Float; |
| -- This is declared aliased because the expansion of X'Valid passes |
| -- X by access and JGNAT requires all access parameters to be aliased. |
| -- The Valid attribute probably needs to be handled via a different |
| -- expansion for JGNAT, and this use of aliased should be removed |
| -- once Valid is handled properly. ??? |
| 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 behaviour, |
| -- 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; |
