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