diff options
author | Eric Botcazou <ebotcazou@adacore.com> | 2020-12-21 08:37:34 +0100 |
---|---|---|
committer | Pierre-Marie de Rodat <derodat@adacore.com> | 2021-05-04 05:17:29 -0400 |
commit | c63bb4f3aaa18b5e4c8722c655187d592faecde3 (patch) | |
tree | bef7b61185e6aa11bbde035d063122c6bfb8f598 /gcc | |
parent | d4b0a294694a145aa33a25d1f923f4085b8f7d99 (diff) | |
download | gcc-c63bb4f3aaa18b5e4c8722c655187d592faecde3.zip gcc-c63bb4f3aaa18b5e4c8722c655187d592faecde3.tar.gz gcc-c63bb4f3aaa18b5e4c8722c655187d592faecde3.tar.bz2 |
[Ada] Preliminary cleanup in floating-point output implementation
gcc/ada/
* exp_intr.adb: Remove with/use clauses for Urealp.
(Expand_Is_Negative): Delete.
(Expand_Intrinsic_Call): Do not call it.
* rtsfind.ads (RE_Id): Remove RE_Float_Unsigned.
(RE_Unit_Table): Remove entry for RE_Float_Unsigned.
* snames.ads-tmpl (Name_Is_Negative): Delete.
* libgnat/s-imgrea.ads (Set_Image_Real): Fix mode of S parameter.
* libgnat/s-imgrea.adb: Add with/use clauses for System.Img_Util.
(LLU): New subtype.
(Maxdigs): Use it.
(Is_Negative): Reimplement.
(Image_Floating_Point): Simplify.
(Set_Image_Real): Fix mode of S parameter. Remove the low-level
processing on characters. Flip the sign of the Scale variable.
Compute the maximum number of digits for the straight notation.
Call Set_Decimal_Digits at the end to do the final formatting.
* libgnat/s-imguti.ads (Floating_Invalid_Value): New type.
(Set_Floating_Invalid_Value): New procedure.
* libgnat/s-imguti.adb (Set_Floating_Invalid_Value): Implement it
based on existing code from Set_Image_Real.
* libgnat/s-unstyp.ads (Float_Unsigned): Delete.
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/ada/exp_intr.adb | 59 | ||||
-rw-r--r-- | gcc/ada/libgnat/s-imgrea.adb | 469 | ||||
-rw-r--r-- | gcc/ada/libgnat/s-imgrea.ads | 2 | ||||
-rw-r--r-- | gcc/ada/libgnat/s-imguti.adb | 81 | ||||
-rw-r--r-- | gcc/ada/libgnat/s-imguti.ads | 15 | ||||
-rw-r--r-- | gcc/ada/libgnat/s-unstyp.ads | 3 | ||||
-rw-r--r-- | gcc/ada/rtsfind.ads | 2 | ||||
-rw-r--r-- | gcc/ada/snames.ads-tmpl | 1 |
8 files changed, 196 insertions, 436 deletions
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 0eecd1c..e2c3e34 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -54,7 +54,6 @@ with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; with Uintp; use Uintp; -with Urealp; use Urealp; package body Exp_Intr is @@ -66,9 +65,6 @@ package body Exp_Intr is -- Expand a call to an intrinsic arithmetic operator when the operand -- types or sizes are not identical. - procedure Expand_Is_Negative (N : Node_Id); - -- Expand a call to the intrinsic Is_Negative function - procedure Expand_Dispatching_Constructor_Call (N : Node_Id); -- Expand a call to an instantiation of Generic_Dispatching_Constructor -- into a dispatching call to the actual subprogram associated with the @@ -636,9 +632,6 @@ package body Exp_Intr is then Expand_Import_Call (N); - elsif Nam = Name_Is_Negative then - Expand_Is_Negative (N); - elsif Nam = Name_Rotate_Left then Expand_Shift (N, E, N_Op_Rotate_Left); @@ -696,58 +689,6 @@ package body Exp_Intr is end if; end Expand_Intrinsic_Call; - ------------------------ - -- Expand_Is_Negative -- - ------------------------ - - procedure Expand_Is_Negative (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Opnd : constant Node_Id := Relocate_Node (First_Actual (N)); - - begin - - -- We replace the function call by the following expression - - -- if Opnd < 0.0 then - -- True - -- else - -- if Opnd > 0.0 then - -- False; - -- else - -- Float_Unsigned!(Float (Opnd)) /= 0 - -- end if; - -- end if; - - Rewrite (N, - Make_If_Expression (Loc, - Expressions => New_List ( - Make_Op_Lt (Loc, - Left_Opnd => Duplicate_Subexpr (Opnd), - Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), - - New_Occurrence_Of (Standard_True, Loc), - - Make_If_Expression (Loc, - Expressions => New_List ( - Make_Op_Gt (Loc, - Left_Opnd => Duplicate_Subexpr_No_Checks (Opnd), - Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), - - New_Occurrence_Of (Standard_False, Loc), - - Make_Op_Ne (Loc, - Left_Opnd => - Unchecked_Convert_To - (RTE (RE_Float_Unsigned), - Convert_To - (Standard_Float, - Duplicate_Subexpr_No_Checks (Opnd))), - Right_Opnd => - Make_Integer_Literal (Loc, 0))))))); - - Analyze_And_Resolve (N, Standard_Boolean); - end Expand_Is_Negative; - ------------------ -- Expand_Shift -- ------------------ diff --git a/gcc/ada/libgnat/s-imgrea.adb b/gcc/ada/libgnat/s-imgrea.adb index 6c08dcf..3ec4156 100644 --- a/gcc/ada/libgnat/s-imgrea.adb +++ b/gcc/ada/libgnat/s-imgrea.adb @@ -31,11 +31,15 @@ with System.Img_LLU; use System.Img_LLU; with System.Img_Uns; use System.Img_Uns; +with System.Img_Util; use System.Img_Util; with System.Powten_LLF; use System.Powten_LLF; + with System.Float_Control; package body System.Img_Real is + subtype LLU is Long_Long_Unsigned; + -- 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 @@ -46,18 +50,13 @@ package body System.Img_Real is -- 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 + -- 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'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 + Maxdigs : constant := Natural'Min (LLU'Width - 2, Long_Long_Float'Digits); Maxscaling : constant := 5000; -- Max decimal scaling required during conversion of floating-point @@ -69,7 +68,8 @@ package body System.Img_Real is -- enough room for scaling such values function Is_Negative (V : Long_Long_Float) return Boolean; - pragma Import (Intrinsic, Is_Negative); + -- 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_Floating_Point -- @@ -86,14 +86,12 @@ package body System.Img_Real is 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 + -- 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 <= Long_Long_Float'Last) - or else (not Long_Long_Float'Signed_Zeros and then V = -0.0) - then + if not Is_Negative (V) and then V <= Long_Long_Float'Last then pragma Annotate (CodePeer, False_Positive, "condition predetermined", "CodePeer analysis ignores NaN and Inf values"); pragma Assert (S'Last > 1); @@ -133,68 +131,59 @@ package body System.Img_Real is Set_Image_Real (V, S, P, 1, Aft, 0); end Image_Ordinary_Fixed_Point; + ----------------- + -- Is_Negative -- + ----------------- + + function Is_Negative (V : Long_Long_Float) return Boolean is + begin + if V < 0.0 then + return True; + + elsif V > 0.0 then + return False; + + elsif not Long_Long_Float'Signed_Zeros then + return False; + + else + return Long_Long_Float'Copy_Sign (1.0, V) < 0.0; + end if; + end Is_Negative; + -------------------- -- Set_Image_Real -- -------------------- procedure Set_Image_Real (V : Long_Long_Float; - S : out String; + S : in out String; P : in out Natural; Fore : Natural; Aft : Natural; Exp : Natural) is NFrac : constant Natural := Natural'Max (Aft, 1); - Minus : Boolean; - X : Long_Long_Float; - Scale : Integer; - Expon : Integer; + -- Number of digits after the decimal point - Digs : String (1 .. Max_Real_Image_Length); - -- Array used to hold digits of converted integer value. This is a large - -- enough buffer to accommodate ludicrous Fore/Aft/Exp combinations. + 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 : Long_Long_Float; + -- 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. 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); + -- 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 -- @@ -216,9 +205,9 @@ package body System.Img_Real is loop XP := X * Powten (Maxpow); - exit when XP >= Powten (S - 1) or else Scale < -Maxscaling; + exit when XP >= Powten (S - 1) or else Scale > Maxscaling; X := XP; - Scale := Scale - Maxpow; + Scale := Scale + Maxpow; end loop; -- The following exception is only raised in case of erroneous @@ -227,7 +216,7 @@ package body System.Img_Real is -- when a system which is supposed to be IEEE-compliant, but -- has been reconfigured to flush denormals to zero. - if Scale < -Maxscaling then + if Scale > Maxscaling then raise Constraint_Error; end if; @@ -275,7 +264,7 @@ package body System.Img_Real is end loop; X := XP; - Scale := Scale - Mid; + Scale := Scale + Mid; -- Cases where scaling down is required @@ -288,9 +277,9 @@ package body System.Img_Real is loop XP := X / Powten (Maxpow); - exit when XP < Powten (S) or else Scale > Maxscaling; + exit when XP < Powten (S) or else Scale < -Maxscaling; X := XP; - Scale := Scale + Maxpow; + Scale := Scale - Maxpow; end loop; -- The following exception is only raised in case of erroneous @@ -299,7 +288,7 @@ package body System.Img_Real is -- when a system which is supposed to be IEEE-compliant, but -- has been reconfigured to flush denormals to zero. - if Scale > Maxscaling then + if Scale < -Maxscaling then raise Constraint_Error; end if; @@ -341,141 +330,15 @@ package body System.Img_Real is end loop; X := XP; - Scale := Scale + Mid; + 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 - pragma Assert (X in 0.0 .. Long_Long_Float (Unsigned'Last)); - 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 - pragma Assert (X < Powten (Maxdigs)); - pragma Assert - (X in 0.0 .. Long_Long_Float (Long_Long_Unsigned'Last)); - - 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 - pragma Assert (P in S'First - 1 .. S'Last - 1); - -- No check is done as documented in the header: updating P to point - -- to the last character stored, the caller promises that the buffer - -- is large enough and no check is made for this. Constraint_Error - -- will not necessarily be raised if this requirement is violated, - -- since it is perfectly valid to compile this unit with checks off. - P := P + 1; - S (P) := C; - end Set; - - ------------------------- - -- Set_Blanks_And_Sign -- - ------------------------- - - procedure Set_Blanks_And_Sign (N : Integer) is - begin - if Minus 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 - pragma Assert (S >= Digs'First and E <= Digs'Last); - -- S and E should be in the Digs array range - 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 - pragma Assert ((Fore + Aft - N + 1) in Natural); - -- Fore + Aft - N + 1 should be in the Natural range - F := Fore + 1 + Aft - N; - - if Exp /= 0 then - pragma Assert (F + Exp + 1 <= Natural'Last); - -- F + Exp + 1 should be in the Natural range - 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 @@ -486,9 +349,7 @@ package body System.Img_Real is System.Float_Control.Reset; - Scale := 0; - - -- Deal with invalid values first, + -- Deal with invalid values first if not V'Valid then @@ -500,218 +361,86 @@ package body System.Img_Real is -- 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 the following two tests succeed, then we definitely have + -- an infinite value, so we print +Inf or -Inf. if V > Long_Long_Float'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 ('+'); - 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; + Set_Floating_Invalid_Value (Infinity, S, P, Fore, Aft, Exp); - return; - end if; - - -- Positive values - - if V > 0.0 then - X := V; - Minus := False; - - -- Negative values - - elsif V < 0.0 then - X := -V; - Minus := True; + elsif V < Long_Long_Float'First then + Set_Floating_Invalid_Value (Minus_Infinity, S, P, Fore, Aft, Exp); - -- Zero values + -- In all other cases we print NaN - elsif V = 0.0 then - if Long_Long_Float'Signed_Zeros and then Is_Negative (V) then - Minus := True; else - Minus := False; - 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)); + Set_Floating_Invalid_Value (Not_A_Number, S, P, Fore, Aft, Exp); 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 Minus 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 + -- Set the first character like Image - -- In this situation, we only to generate a reasonable - -- number of significant digits, and then zeroes after. - -- So first we rescale to get: + Digs (1) := (if Is_Negative (V) then '-' else ' '); + Ndigs := 1; - -- 10 ** (Maxdigs - 1) <= X < 10 ** Maxdigs + X := abs (V); - -- and then convert the resulting integer + -- If X is zero, we are done - Adjust_Scale (Maxdigs); - Convert_Integer; + if X = 0.0 then + Digs (2) := '0'; + Ndigs := 2; - -- 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; - pragma Assert (Ndigs <= Digs'Last); - 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 + -- Otherwise, scale X and convert it to an integer else - -- If NFrac is less than Maxdigs, then all the fraction digits are - -- significant, so we can scale the resulting integer accordingly. + -- In exponent notation, we need exactly NFrac + 1 digits and always + -- round the last one. - if NFrac < Maxdigs then - Adjust_Scale (NFrac + 1); - Convert_Integer; + if Exp > 0 then + Adjust_Scale (Natural'Min (NFrac + 1, Maxdigs)); + X := X + 0.5; - -- Otherwise, we get the maximum number of digits available + -- 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); - Convert_Integer; - - for J in 1 .. NFrac - Maxdigs + 1 loop - Ndigs := Ndigs + 1; - pragma Assert (Ndigs <= Digs'Last); - Digs (Ndigs) := '0'; - Scale := Scale - 1; - end loop; + if Scale <= NFrac then + X := X + 0.5; + end if; 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; + -- Use Unsigned routine if possible, since on 32-bit machines it will + -- be significantly more efficient than the Long_Long_Unsigned one. - if Expon >= 0 then - Set ('+'); - Set_Image_Unsigned (Unsigned (Expon), Digs, Ndigs); - else - Set ('-'); - Set_Image_Unsigned (Unsigned (-Expon), Digs, Ndigs); + if X <= Long_Long_Float (Unsigned'Last) then + declare + I : constant Unsigned := + Unsigned (Long_Long_Float'Truncation (X)); + begin + Set_Image_Unsigned (I, Digs, Ndigs); + end; + + else pragma Assert (X <= Long_Long_Float (LLU'Last)); + declare + I : constant LLU := + LLU (Long_Long_Float'Truncation (X)); + begin + Set_Image_Long_Long_Unsigned (I, Digs, Ndigs); + end; end if; - - Set_Zeros (Exp - Ndigs - 1); - Set_Digs (1, Ndigs); end if; + Set_Decimal_Digits (Digs, Ndigs, S, P, Scale, Fore, Aft, Exp); end Set_Image_Real; end System.Img_Real; diff --git a/gcc/ada/libgnat/s-imgrea.ads b/gcc/ada/libgnat/s-imgrea.ads index 170cb4f..2da869bd 100644 --- a/gcc/ada/libgnat/s-imgrea.ads +++ b/gcc/ada/libgnat/s-imgrea.ads @@ -63,7 +63,7 @@ package System.Img_Real is procedure Set_Image_Real (V : Long_Long_Float; - S : out String; + S : in out String; P : in out Natural; Fore : Natural; Aft : Natural; diff --git a/gcc/ada/libgnat/s-imguti.adb b/gcc/ada/libgnat/s-imguti.adb index f8370c2..e86be49 100644 --- a/gcc/ada/libgnat/s-imguti.adb +++ b/gcc/ada/libgnat/s-imguti.adb @@ -400,4 +400,85 @@ package body System.Img_Util is end if; end Set_Decimal_Digits; + -------------------------------- + -- Set_Floating_Invalid_Value -- + -------------------------------- + + procedure Set_Floating_Invalid_Value + (V : Floating_Invalid_Value; + S : out String; + P : in out Natural; + Fore : Natural; + Aft : Natural; + Exp : Natural) + is + procedure Set (C : Character); + -- Sets character C in output buffer + + 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) + + --------- + -- Set -- + --------- + + procedure Set (C : Character) is + begin + pragma Assert (P in S'First - 1 .. S'Last - 1); + -- No check is done as documented in the header: updating P to point + -- to the last character stored, the caller promises that the buffer + -- is large enough and no check is made for this. Constraint_Error + -- will not necessarily be raised if this requirement is violated, + -- since it is perfectly valid to compile this unit with checks off. + + P := P + 1; + S (P) := C; + end Set; + + ---------------------- + -- Set_Special_Fill -- + ---------------------- + + procedure Set_Special_Fill (N : Natural) is + begin + if Exp /= 0 then + for J in N + 1 .. Fore + 1 + Aft + 1 + Exp loop + Set ('*'); + end loop; + + else + for J in N + 1 .. Fore + 1 + Aft loop + Set ('*'); + end loop; + end if; + end Set_Special_Fill; + + -- Start of processing for Set_Floating_Invalid_Value + + begin + case V is + when Minus_Infinity => + Set ('-'); + Set ('I'); + Set ('n'); + Set ('f'); + Set_Special_Fill (4); + + when Infinity => + Set ('+'); + Set ('I'); + Set ('n'); + Set ('f'); + Set_Special_Fill (4); + + when Not_A_Number => + Set ('N'); + Set ('a'); + Set ('N'); + Set_Special_Fill (3); + end case; + end Set_Floating_Invalid_Value; + end System.Img_Util; diff --git a/gcc/ada/libgnat/s-imguti.ads b/gcc/ada/libgnat/s-imguti.ads index 99cc513..680c0bb 100644 --- a/gcc/ada/libgnat/s-imguti.ads +++ b/gcc/ada/libgnat/s-imguti.ads @@ -58,4 +58,19 @@ package System.Img_Util is -- may destroy the value in Digs, which is why Digs is in-out (this happens -- if rounding is required). + type Floating_Invalid_Value is (Minus_Infinity, Infinity, Not_A_Number); + + procedure Set_Floating_Invalid_Value + (V : Floating_Invalid_Value; + S : out String; + P : in out Natural; + Fore : Natural; + Aft : Natural; + Exp : Natural); + -- Sets the image of a floating-point invalid value, starting at S (P + 1), + -- updating P to point to the last character stored. The caller promises + -- that the buffer is large enough and therefore no check is made for it. + -- Constraint_Error will not necessarily be raised if the requirement is + -- violated since it is valid to compile this unit with checks off. + end System.Img_Util; diff --git a/gcc/ada/libgnat/s-unstyp.ads b/gcc/ada/libgnat/s-unstyp.ads index 21e79b8..197fd24 100644 --- a/gcc/ada/libgnat/s-unstyp.ads +++ b/gcc/ada/libgnat/s-unstyp.ads @@ -48,9 +48,6 @@ package System.Unsigned_Types is type Long_Long_Unsigned is mod 2 ** Long_Long_Integer'Size; type Long_Long_Long_Unsigned is mod Max_Binary_Modulus; - type Float_Unsigned is mod 2 ** Float'Size; - -- Used in the implementation of Is_Negative intrinsic (see Exp_Intr) - type Packed_Byte is mod 2 ** 8; for Packed_Byte'Size use 8; pragma Universal_Aliasing (Packed_Byte); diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 193475f..3bc36a1 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -2004,7 +2004,6 @@ package Rtsfind is RE_Bits_1, -- System.Unsigned_Types RE_Bits_2, -- System.Unsigned_Types RE_Bits_4, -- System.Unsigned_Types - RE_Float_Unsigned, -- System.Unsigned_Types RE_Long_Long_Unsigned, -- System.Unsigned_Types RE_Long_Long_Long_Unsigned, -- System.Unsigned_Types RE_Packed_Byte, -- System.Unsigned_Types @@ -3684,7 +3683,6 @@ package Rtsfind is RE_Bits_1 => System_Unsigned_Types, RE_Bits_2 => System_Unsigned_Types, RE_Bits_4 => System_Unsigned_Types, - RE_Float_Unsigned => System_Unsigned_Types, RE_Long_Long_Unsigned => System_Unsigned_Types, RE_Long_Long_Long_Unsigned => System_Unsigned_Types, RE_Packed_Byte => System_Unsigned_Types, diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index b431c2c..206e915 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1333,7 +1333,6 @@ package Snames is Name_Import_Address : constant Name_Id := N + $; Name_Import_Largest_Value : constant Name_Id := N + $; Name_Import_Value : constant Name_Id := N + $; - Name_Is_Negative : constant Name_Id := N + $; Name_Line : constant Name_Id := N + $; Name_Rotate_Left : constant Name_Id := N + $; Name_Rotate_Right : constant Name_Id := N + $; |