From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 7871) id DFBA53858011; Tue, 6 Sep 2022 07:15:28 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org DFBA53858011 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1662448528; bh=XFH/MyhjCV9YtMURiKAZ3DjmSVAYxcaA9HZr60QwfcU=; h=From:To:Subject:Date:From; b=T5x0iqxZuGe30lF6jXuKFp7v19vAQgfiFD798P1Cphw3ZsrfJ4He0QNCWNbaHDWPa SfttNr1Rz0ydXhj7tqYn9LXNVxpvu+PWfWJDyOSrLHB46TDBDF0aUnSq1iDaFJfB0q vSgckkk8zHmCfqGMFbo+JgLMdLO8NEbrfkvdFiDA= MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: =?iso-8859-1?q?Marc_Poulhi=E8s?= To: gcc-cvs@gcc.gnu.org Subject: [gcc r13-2457] [Ada] Correctly round Value attribute for floating point in more cases X-Act-Checkin: gcc X-Git-Author: Eric Botcazou X-Git-Refname: refs/heads/master X-Git-Oldrev: 33b182f61280d991bd0bda33003b5ee2a16024e2 X-Git-Newrev: d6b15134378bfba88effc523f4eb2c20a9486a63 Message-Id: <20220906071528.DFBA53858011@sourceware.org> Date: Tue, 6 Sep 2022 07:15:28 +0000 (GMT) List-Id: https://gcc.gnu.org/g:d6b15134378bfba88effc523f4eb2c20a9486a63 commit r13-2457-gd6b15134378bfba88effc523f4eb2c20a9486a63 Author: Eric Botcazou Date: Mon Aug 1 23:10:40 2022 +0200 [Ada] Correctly round Value attribute for floating point in more cases This provides correct rounding in the IEEE 754 sense for the Value attribute of floating-point types in more cases, by bumping the number of significant bits used in the initial integer mantissa obtained from parsing. gcc/ada/ * libgnat/s-valuer.ads (System.Value_R): Add Parts formal parameter as well as Data_Index, Scale_Array and Value_Array types. (Scan_Raw_Real): Change type of Scale and return type. (Value_Raw_Real): Likewise. * libgnat/s-valuer.adb (Round_Extra): Reorder parameters and adjust recursive call. (Scan_Decimal_Digits): Reorder parameters, add N parameter and deal with multi-part scale and value. (Scan_Integral_Digits): Likewise. (Scan_Raw_Real): Change type of Scale and return type and deal with multi-part scale and value. (Value_Raw_Real): Change type of Scale and return type and tidy up. * libgnat/s-valued.adb (Impl): Pass 1 as Parts actual parameter. (Scan_Decimal): Adjust to type changes. (Value_Decimal): Likewise. * libgnat/s-valuef.adb (Impl): Pass 1 as Parts actual parameter. (Scan_Fixed): Adjust to type changes. (Value_Fixed): Likewise. * libgnat/s-valrea.adb (Need_Extra): Delete. (Precision_Limit): Always use the precision of the mantissa. (Impl): Pass 2 as Parts actual parameter. (Exact_Log2): New expression function. (Integer_to_Real): Change type of Scale and Val and deal with a 2-part integer mantissa. (Scan_Real): Adjust to type changes. (Value_Real): Likewise. Diff: --- gcc/ada/libgnat/s-valrea.adb | 186 +++++++++++++++++++---------------------- gcc/ada/libgnat/s-valued.adb | 30 +++---- gcc/ada/libgnat/s-valuef.adb | 32 ++++---- gcc/ada/libgnat/s-valuer.adb | 192 +++++++++++++++++++++++++------------------ gcc/ada/libgnat/s-valuer.ads | 31 +++++-- 5 files changed, 253 insertions(+), 218 deletions(-) diff --git a/gcc/ada/libgnat/s-valrea.adb b/gcc/ada/libgnat/s-valrea.adb index c9e5505c93c..b712ba6827a 100644 --- a/gcc/ada/libgnat/s-valrea.adb +++ b/gcc/ada/libgnat/s-valrea.adb @@ -43,18 +43,9 @@ package body System.Val_Real is pragma Assert (Num'Machine_Mantissa <= Uns'Size); -- We need an unsigned type large enough to represent the mantissa - Need_Extra : constant Boolean := Num'Machine_Mantissa > Uns'Size - 4; - -- If the mantissa of the floating-point type is almost as large as the - -- unsigned type, we do not have enough space for an extra digit in the - -- unsigned type so we handle the extra digit separately, at the cost of - -- a bit more work in Integer_to_Real. + Precision_Limit : constant Uns := 2**Num'Machine_Mantissa - 1; - Precision_Limit : constant Uns := - (if Need_Extra then 2**Num'Machine_Mantissa - 1 else 2**Uns'Size - 1); - -- If we handle the extra digit separately, we use the precision of the - -- floating-point type so that the conversion is exact. - - package Impl is new Value_R (Uns, Precision_Limit, Round => Need_Extra); + package Impl is new Value_R (Uns, 2, Precision_Limit, Round => False); subtype Base_T is Unsigned range 2 .. 16; @@ -83,12 +74,20 @@ package body System.Val_Real is subtype Double_T is Double_Real.Double_T; -- The double floating-point type + function Exact_Log2 (N : Unsigned) return Positive is + (case N is + when 2 => 1, + when 4 => 2, + when 8 => 3, + when 16 => 4, + when others => raise Program_Error); + -- Return the exponent of a power of 2 + function Integer_to_Real (Str : String; - Val : Uns; + Val : Impl.Value_Array; Base : Unsigned; - Scale : Integer; - Extra : Unsigned; + Scale : Impl.Scale_Array; Minus : Boolean) return Num; -- Convert the real value from integer to real representation @@ -101,10 +100,9 @@ package body System.Val_Real is function Integer_to_Real (Str : String; - Val : Uns; + Val : Impl.Value_Array; Base : Unsigned; - Scale : Integer; - Extra : Unsigned; + Scale : Impl.Scale_Array; Minus : Boolean) return Num is pragma Assert (Base in 2 .. 16); @@ -120,9 +118,9 @@ package body System.Val_Real is else raise Program_Error); -- Maximum exponent of the base that can fit in Num - R_Val : Num; D_Val : Double_T; - S : Integer := Scale; + R_Val : Num; + S : Integer; begin -- We call the floating-point processor reset routine so we can be sure @@ -134,82 +132,78 @@ package body System.Val_Real is System.Float_Control.Reset; end if; - -- Take into account the extra digit, i.e. do the two computations - - -- (1) R_Val := R_Val * Num (B) + Num (Extra) - -- (2) S := S - 1 + -- First convert the integer mantissa into a double real. The conversion + -- of each part is exact, given the precision limit we used above. Then, + -- if the contribution of the low part might be nonnull, scale the high + -- part appropriately and add the low part to the result. - -- In the first, the three operands are exact, so using an FMA would - -- be ideal, but we are most likely running on the x87 FPU, hence we - -- may not have one. That is why we turn the multiplication into an - -- iterated addition with exact error handling, so that we can do a - -- single rounding at the end. + if Val (2) = 0 then + D_Val := Double_Real.To_Double (Num (Val (1))); + S := Scale (1); - if Need_Extra and then Extra > 0 then + else declare - B : Unsigned := Base; - Acc : Num := 0.0; - Err : Num := 0.0; - Fac : Num := Num (Val); - DS : Double_T; + V1 : constant Num := Num (Val (1)); + V2 : constant Num := Num (Val (2)); + + DS : Positive; begin - loop - -- If B is odd, add one factor. Note that the accumulator is - -- never larger than the factor at this point (it is in fact - -- never larger than the factor minus the initial value). - - if B rem 2 /= 0 then - if Acc = 0.0 then - Acc := Fac; - else - DS := Double_Real.Quick_Two_Sum (Fac, Acc); - Acc := DS.Hi; - Err := Err + DS.Lo; - end if; - exit when B = 1; - end if; + DS := Scale (1) - Scale (2); - -- Now B is (morally) even, halve it and double the factor, - -- which is always an exact operation. + case Base is + -- If the base is a power of two, we use the efficient Scaling + -- attribute up to an amount worth a double mantissa. - B := B / 2; - Fac := Fac * 2.0; - end loop; + when 2 | 4 | 8 | 16 => + declare + L : constant Positive := Exact_Log2 (Base); - -- Add Extra to the error, which are both small integers + begin + if DS <= 2 * Num'Machine_Mantissa / L then + DS := DS * L; + D_Val := + Double_Real.Quick_Two_Sum (Num'Scaling (V1, DS), V2); + S := Scale (2); - D_Val := Double_Real.Quick_Two_Sum (Acc, Err + Num (Extra)); + else + D_Val := Double_Real.To_Double (V1); + S := Scale (1); + end if; + end; - S := S - 1; - end; + -- If the base is 10, we also scale up to an amount worth a + -- double mantissa. - -- Or else, if the Extra digit is zero, do the exact conversion + when 10 => + declare + Powten : constant array (0 .. Maxpow) of Double_T; + pragma Import (Ada, Powten); + for Powten'Address use Powten_Address; - elsif Need_Extra then - D_Val := Double_Real.To_Double (Num (Val)); + begin + if DS <= Maxpow then + D_Val := Powten (DS) * V1 + V2; + S := Scale (2); - -- Otherwise, the value contains more bits than the mantissa so do the - -- conversion in two steps. + else + D_Val := Double_Real.To_Double (V1); + S := Scale (1); + end if; + end; - else - declare - Mask : constant Uns := 2**(Uns'Size - Num'Machine_Mantissa) - 1; - Hi : constant Uns := Val and not Mask; - Lo : constant Uns := Val and Mask; + -- Inaccurate implementation for other bases - begin - if Hi = 0 then - D_Val := Double_Real.To_Double (Num (Lo)); - else - D_Val := Double_Real.Quick_Two_Sum (Num (Hi), Num (Lo)); - end if; + when others => + D_Val := Double_Real.To_Double (V1); + S := Scale (1); + end case; end; end if; -- Compute the final value by applying the scaling, if any - if Val = 0 or else S = 0 then + if (Val (1) = 0 and then Val (2) = 0) or else S = 0 then R_Val := Double_Real.To_Single (D_Val); else @@ -218,29 +212,17 @@ package body System.Val_Real is -- attribute with an overflow check, if it is not 2, to catch -- ludicrous exponents that would result in an infinity or zero. - when 2 => - R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); - - when 4 => - if Integer'First / 2 <= S and then S <= Integer'Last / 2 then - S := S * 2; - end if; - - R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); - - when 8 => - if Integer'First / 3 <= S and then S <= Integer'Last / 3 then - S := S * 3; - end if; - - R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); + when 2 | 4 | 8 | 16 => + declare + L : constant Positive := Exact_Log2 (Base); - when 16 => - if Integer'First / 4 <= S and then S <= Integer'Last / 4 then - S := S * 4; - end if; + begin + if Integer'First / L <= S and then S <= Integer'Last / L then + S := S * L; + end if; - R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); + R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); + end; -- If the base is 10, use a double implementation for the sake -- of accuracy, to be removed when exponentiation is improved. @@ -358,15 +340,15 @@ package body System.Val_Real is Max : Integer) return Num is Base : Unsigned; - Scale : Integer; + Scale : Impl.Scale_Array; Extra : Unsigned; Minus : Boolean; - Val : Uns; + Val : Impl.Value_Array; begin Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scale, Extra, Minus); - return Integer_to_Real (Str, Val, Base, Scale, Extra, Minus); + return Integer_to_Real (Str, Val, Base, Scale, Minus); end Scan_Real; ---------------- @@ -375,15 +357,15 @@ package body System.Val_Real is function Value_Real (Str : String) return Num is Base : Unsigned; - Scale : Integer; + Scale : Impl.Scale_Array; Extra : Unsigned; Minus : Boolean; - Val : Uns; + Val : Impl.Value_Array; begin Val := Impl.Value_Raw_Real (Str, Base, Scale, Extra, Minus); - return Integer_to_Real (Str, Val, Base, Scale, Extra, Minus); + return Integer_to_Real (Str, Val, Base, Scale, Minus); end Value_Real; end System.Val_Real; diff --git a/gcc/ada/libgnat/s-valued.adb b/gcc/ada/libgnat/s-valued.adb index c4a78a2ac87..92e9140443e 100644 --- a/gcc/ada/libgnat/s-valued.adb +++ b/gcc/ada/libgnat/s-valued.adb @@ -38,7 +38,7 @@ package body System.Value_D is pragma Assert (Int'Size <= Uns'Size); -- We need an unsigned type large enough to represent the mantissa - package Impl is new Value_R (Uns, 2**(Int'Size - 1), Round => False); + package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1), Round => False); -- We do not use the Extra digit for decimal fixed-point types function Integer_to_Decimal @@ -229,16 +229,16 @@ package body System.Value_D is Max : Integer; Scale : Integer) return Int is - Base : Unsigned; - ScaleB : Integer; - Extra : Unsigned; - Minus : Boolean; - Val : Uns; + Base : Unsigned; + Scl : Impl.Scale_Array; + Extra : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus); + Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra, Minus); - return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale); + return Integer_to_Decimal (Str, Val (1), Base, Scl (1), Minus, Scale); end Scan_Decimal; ------------------- @@ -246,16 +246,16 @@ package body System.Value_D is ------------------- function Value_Decimal (Str : String; Scale : Integer) return Int is - Base : Unsigned; - ScaleB : Integer; - Extra : Unsigned; - Minus : Boolean; - Val : Uns; + Base : Unsigned; + Scl : Impl.Scale_Array; + Extra : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus); + Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra, Minus); - return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale); + return Integer_to_Decimal (Str, Val (1), Base, Scl (1), Minus, Scale); end Value_Decimal; end System.Value_D; diff --git a/gcc/ada/libgnat/s-valuef.adb b/gcc/ada/libgnat/s-valuef.adb index e252a285364..1b9d18ef708 100644 --- a/gcc/ada/libgnat/s-valuef.adb +++ b/gcc/ada/libgnat/s-valuef.adb @@ -46,7 +46,7 @@ package body System.Value_F is pragma Assert (Int'Size <= Uns'Size); -- We need an unsigned type large enough to represent the mantissa - package Impl is new Value_R (Uns, 2**(Int'Size - 1), Round => True); + package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1), Round => True); -- We use the Extra digit for ordinary fixed-point types function Integer_To_Fixed @@ -332,16 +332,17 @@ package body System.Value_F is Num : Int; Den : Int) return Int is - Base : Unsigned; - ScaleB : Integer; - Extra : Unsigned; - Minus : Boolean; - Val : Uns; + Base : Unsigned; + Scl : Impl.Scale_Array; + Extra : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus); + Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra, Minus); - return Integer_To_Fixed (Str, Val, Base, ScaleB, Extra, Minus, Num, Den); + return + Integer_To_Fixed (Str, Val (1), Base, Scl (1), Extra, Minus, Num, Den); end Scan_Fixed; ----------------- @@ -353,16 +354,17 @@ package body System.Value_F is Num : Int; Den : Int) return Int is - Base : Unsigned; - ScaleB : Integer; - Extra : Unsigned; - Minus : Boolean; - Val : Uns; + Base : Unsigned; + Scl : Impl.Scale_Array; + Extra : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus); + Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra, Minus); - return Integer_To_Fixed (Str, Val, Base, ScaleB, Extra, Minus, Num, Den); + return + Integer_To_Fixed (Str, Val (1), Base, Scl (1), Extra, Minus, Num, Den); end Value_Fixed; end System.Value_F; diff --git a/gcc/ada/libgnat/s-valuer.adb b/gcc/ada/libgnat/s-valuer.adb index fc916606343..c55444a1ec7 100644 --- a/gcc/ada/libgnat/s-valuer.adb +++ b/gcc/ada/libgnat/s-valuer.adb @@ -44,22 +44,23 @@ package body System.Value_R is procedure Round_Extra (Digit : Char_As_Digit; + Base : Unsigned; Value : in out Uns; Scale : in out Integer; - Extra : in out Char_As_Digit; - Base : Unsigned); + Extra : in out Char_As_Digit); -- Round the triplet (Value, Scale, Extra) according to Digit in Base procedure Scan_Decimal_Digits (Str : String; Index : in out Integer; Max : Integer; - Value : in out Uns; - Scale : in out Integer; - Extra : in out Char_As_Digit; - Base_Violation : in out Boolean; Base : Unsigned; - Base_Specified : Boolean); + Base_Specified : Boolean; + Value : in out Value_Array; + Scale : in out Scale_Array; + N : in out Positive; + Extra : in out Char_As_Digit; + Base_Violation : in out Boolean); -- Scan the decimal part of a real (i.e. after decimal separator) -- -- The string parsed is Str (Index .. Max) and after the call Index will @@ -77,12 +78,13 @@ package body System.Value_R is (Str : String; Index : in out Integer; Max : Integer; - Value : out Uns; - Scale : out Integer; - Extra : out Char_As_Digit; - Base_Violation : in out Boolean; Base : Unsigned; - Base_Specified : Boolean); + Base_Specified : Boolean; + Value : out Value_Array; + Scale : out Scale_Array; + N : out Positive; + Extra : out Char_As_Digit; + Base_Violation : in out Boolean); -- Scan the integral part of a real (i.e. before decimal separator) -- -- The string parsed is Str (Index .. Max) and after the call Index will @@ -123,10 +125,10 @@ package body System.Value_R is procedure Round_Extra (Digit : Char_As_Digit; + Base : Unsigned; Value : in out Uns; Scale : in out Integer; - Extra : in out Char_As_Digit; - Base : Unsigned) + Extra : in out Char_As_Digit) is pragma Assert (Base in 2 .. 16); @@ -145,7 +147,7 @@ package body System.Value_R is Extra := Char_As_Digit (Value mod B); Value := Value / B; Scale := Scale + 1; - Round_Extra (Digit, Value, Scale, Extra, Base); + Round_Extra (Digit, Base, Value, Scale, Extra); else Extra := 0; @@ -166,12 +168,13 @@ package body System.Value_R is (Str : String; Index : in out Integer; Max : Integer; - Value : in out Uns; - Scale : in out Integer; - Extra : in out Char_As_Digit; - Base_Violation : in out Boolean; Base : Unsigned; - Base_Specified : Boolean) + Base_Specified : Boolean; + Value : in out Value_Array; + Scale : in out Scale_Array; + N : in out Positive; + Extra : in out Char_As_Digit; + Base_Violation : in out Boolean) is pragma Assert (Base in 2 .. 16); @@ -205,7 +208,7 @@ package body System.Value_R is -- If initial Scale is not 0 then it means that Precision_Limit was -- reached during scanning of the integral part. - if Scale > 0 then + if Scale (Data_Index'Last) > 0 then Precision_Limit_Reached := True; else Extra := 0; @@ -247,7 +250,7 @@ package body System.Value_R is if Precision_Limit_Reached then if Round and then Precision_Limit_Just_Reached then - Round_Extra (Digit, Value, Scale, Extra, Base); + Round_Extra (Digit, Base, Value (N), Scale (N), Extra); Precision_Limit_Just_Reached := False; end if; @@ -258,19 +261,24 @@ package body System.Value_R is Trailing_Zeros := Trailing_Zeros + 1; else - -- Handle accumulated zeros. + -- Handle accumulated zeros for J in 1 .. Trailing_Zeros loop - if Value <= UmaxB then - Value := Value * Uns (Base); - Scale := Scale - 1; + if Value (N) <= UmaxB then + Value (N) := Value (N) * Uns (Base); + Scale (N) := Scale (N) - 1; + + elsif Parts > 1 and then N < Data_Index'Last then + N := N + 1; + Scale (N) := Scale (N - 1) - 1; else Extra := 0; Precision_Limit_Reached := True; if Round and then J = Trailing_Zeros then - Round_Extra (Digit, Value, Scale, Extra, Base); + Round_Extra (Digit, Base, Value (N), Scale (N), Extra); end if; + exit; end if; end loop; @@ -281,7 +289,7 @@ package body System.Value_R is -- Handle current non zero digit - Temp := Value * Uns (Base) + Uns (Digit); + Temp := Value (N) * Uns (Base) + Uns (Digit); -- Precision_Limit_Reached may have been set above @@ -292,15 +300,20 @@ package body System.Value_R is -- account that Temp may wrap around when Precision_Limit is -- equal to the largest integer. - elsif Value <= Umax - or else (Value <= UmaxB + elsif Value (N) <= Umax + or else (Value (N) <= UmaxB and then ((Precision_Limit < Uns'Last and then Temp <= Precision_Limit) or else (Precision_Limit = Uns'Last and then Temp >= Uns (Base)))) then - Value := Temp; - Scale := Scale - 1; + Value (N) := Temp; + Scale (N) := Scale (N) - 1; + + elsif Parts > 1 and then N < Data_Index'Last then + N := N + 1; + Value (N) := Uns (Digit); + Scale (N) := Scale (N - 1) - 1; else Extra := Digit; @@ -352,12 +365,13 @@ package body System.Value_R is (Str : String; Index : in out Integer; Max : Integer; - Value : out Uns; - Scale : out Integer; - Extra : out Char_As_Digit; - Base_Violation : in out Boolean; Base : Unsigned; - Base_Specified : Boolean) + Base_Specified : Boolean; + Value : out Value_Array; + Scale : out Scale_Array; + N : out Positive; + Extra : out Char_As_Digit; + Base_Violation : in out Boolean) is pragma Assert (Base in 2 .. 16); @@ -382,10 +396,11 @@ package body System.Value_R is -- Temporary begin - -- Initialize Value, Scale and Extra + -- Initialize N, Value, Scale and Extra - Value := 0; - Scale := 0; + N := 1; + Value := (others => 0); + Scale := (others => 0); Extra := 0; Precision_Limit_Reached := False; @@ -422,28 +437,32 @@ package body System.Value_R is -- should continue only to assess the validity of the string. if Precision_Limit_Reached then - Scale := Scale + 1; + Scale (N) := Scale (N) + 1; if Round and then Precision_Limit_Just_Reached then - Round_Extra (Digit, Value, Scale, Extra, Base); + Round_Extra (Digit, Base, Value (N), Scale (N), Extra); Precision_Limit_Just_Reached := False; end if; else - Temp := Value * Uns (Base) + Uns (Digit); + Temp := Value (N) * Uns (Base) + Uns (Digit); -- Check if Temp is larger than Precision_Limit, taking into -- account that Temp may wrap around when Precision_Limit is -- equal to the largest integer. - if Value <= Umax - or else (Value <= UmaxB + if Value (N) <= Umax + or else (Value (N) <= UmaxB and then ((Precision_Limit < Uns'Last and then Temp <= Precision_Limit) or else (Precision_Limit = Uns'Last and then Temp >= Uns (Base)))) then - Value := Temp; + Value (N) := Temp; + + elsif Parts > 1 and then N < Data_Index'Last then + N := N + 1; + Value (N) := Uns (Digit); else Extra := Digit; @@ -451,10 +470,16 @@ package body System.Value_R is if Round then Precision_Limit_Just_Reached := True; end if; - Scale := Scale + 1; + Scale (N) := Scale (N) + 1; end if; end if; + -- Every parsed digit also scales the previous parts + + for J in 1 .. N - 1 loop + Scale (J) := Scale (J) + 1; + end loop; + -- Look for the next character Index := Index + 1; @@ -492,9 +517,9 @@ package body System.Value_R is Ptr : not null access Integer; Max : Integer; Base : out Unsigned; - Scale : out Integer; + Scale : out Scale_Array; Extra : out Unsigned; - Minus : out Boolean) return Uns + Minus : out Boolean) return Value_Array is pragma Assert (Max <= Str'Last); @@ -509,8 +534,11 @@ package body System.Value_R is -- If True some digits where not in the base. The real is still scanned -- till the end even if an error will be raised. + N : Positive; + -- Index number of the current part + Expon : Integer; - -- Exponent as an Integer + -- Exponent as an integer Index : Integer; -- Local copy of string pointer @@ -518,8 +546,8 @@ package body System.Value_R is Start : Positive; -- Index of the first non-blank character - Value : Uns; - -- Mantissa as an Integer + Value : Value_Array; + -- Mantissa as an array of integers begin -- The default base is 10 @@ -554,8 +582,8 @@ package body System.Value_R is -- part or the base to use. Scan_Integral_Digits - (Str, Index, Max, Value, Scale, Char_As_Digit (Extra), - Base_Violation, Base, Base_Specified => False); + (Str, Index, Max, Base, False, Value, Scale, N, + Char_As_Digit (Extra), Base_Violation); -- A dot is allowed only if followed by a digit (RM 3.5(47)) @@ -565,8 +593,9 @@ package body System.Value_R is then After_Point := True; Index := Index + 1; - Value := 0; - Scale := 0; + N := 1; + Value := (others => 0); + Scale := (others => 0); Extra := 0; else @@ -582,8 +611,8 @@ package body System.Value_R is then Base_Char := Str (Index); - if Value in 2 .. 16 then - Base := Unsigned (Value); + if N = 1 and then Value (1) in 2 .. 16 then + Base := Unsigned (Value (1)); else Base_Violation := True; Base := 16; @@ -597,7 +626,7 @@ package body System.Value_R is then After_Point := True; Index := Index + 1; - Value := 0; + Value := (others => 0); end if; end if; @@ -609,8 +638,8 @@ package body System.Value_R is end if; Scan_Integral_Digits - (Str, Index, Max, Value, Scale, Char_As_Digit (Extra), - Base_Violation, Base, Base_Specified => Base_Char /= ASCII.NUL); + (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale, + N, Char_As_Digit (Extra), Base_Violation); end if; -- Do we have a dot? @@ -636,8 +665,8 @@ package body System.Value_R is pragma Assert (Index <= Max); Scan_Decimal_Digits - (Str, Index, Max, Value, Scale, Char_As_Digit (Extra), - Base_Violation, Base, Base_Specified => Base_Char /= ASCII.NUL); + (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale, + N, Char_As_Digit (Extra), Base_Violation); end if; -- If an explicit base was specified ensure that the delimiter is found @@ -660,9 +689,15 @@ package body System.Value_R is -- Handle very large exponents like Scan_Exponent if Expon < Integer'First / 10 or else Expon > Integer'Last / 10 then - Scale := Expon; + Scale (1) := Expon; + for J in 2 .. Data_Index'Last loop + Value (J) := 0; + end loop; + else - Scale := Scale + Expon; + for J in Data_Index'Range loop + Scale (J) := Scale (J) + Expon; + end loop; end if; -- Here is where we check for a bad based number @@ -672,7 +707,6 @@ package body System.Value_R is else return Value; end if; - end Scan_Raw_Real; -------------------- @@ -682,10 +716,13 @@ package body System.Value_R is function Value_Raw_Real (Str : String; Base : out Unsigned; - Scale : out Integer; + Scale : out Scale_Array; Extra : out Unsigned; - Minus : out Boolean) return Uns + Minus : out Boolean) return Value_Array is + P : aliased Integer; + V : Value_Array; + begin -- We have to special case Str'Last = Positive'Last because the normal -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We @@ -697,20 +734,15 @@ package body System.Value_R is begin return Value_Raw_Real (NT (Str), Base, Scale, Extra, Minus); end; + end if; - -- Normal case where Str'Last < Positive'Last + -- Normal case - else - declare - V : Uns; - P : aliased Integer := Str'First; - begin - V := Scan_Raw_Real - (Str, P'Access, Str'Last, Base, Scale, Extra, Minus); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; + P := Str'First; + V := Scan_Raw_Real (Str, P'Access, Str'Last, Base, Scale, Extra, Minus); + Scan_Trailing_Blanks (Str, P); + + return V; end Value_Raw_Real; end System.Value_R; diff --git a/gcc/ada/libgnat/s-valuer.ads b/gcc/ada/libgnat/s-valuer.ads index 3279090ce8a..d9d168ecb3e 100644 --- a/gcc/ada/libgnat/s-valuer.ads +++ b/gcc/ada/libgnat/s-valuer.ads @@ -37,22 +37,37 @@ with System.Unsigned_Types; use System.Unsigned_Types; generic type Uns is mod <>; + -- Modular type used for the value + + Parts : Positive; + -- Number of Uns parts in the value Precision_Limit : Uns; + -- Precision limit for each part of the value Round : Boolean; + -- If Parts = 1, True if the extra digit must be rounded package System.Value_R is pragma Preelaborate; + subtype Data_Index is Positive range 1 .. Parts; + -- The type indexing the value + + type Scale_Array is array (Data_Index) of Integer; + -- The scale for each part of the value + + type Value_Array is array (Data_Index) of Uns; + -- The value split into parts + function Scan_Raw_Real (Str : String; Ptr : not null access Integer; Max : Integer; Base : out Unsigned; - Scale : out Integer; + Scale : out Scale_Array; Extra : out Unsigned; - Minus : out Boolean) return Uns; + Minus : out Boolean) return Value_Array; -- This function scans the string starting at Str (Ptr.all) for a valid -- real literal according to the syntax described in (RM 3.5(43)). The -- substring scanned extends no further than Str (Max). There are three @@ -64,9 +79,13 @@ package System.Value_R is -- parameters are set; if Val is the result of the call, then the real -- represented by the literal is equal to -- - -- (Val * Base + Extra) * (Base ** (Scale - 1)) + -- (Val (1) * Base + Extra) * (Base ** (Scale (1) - 1)) + -- + -- when Parts = 1 and + -- + -- Sum [Val (N) * (Base ** Scale (N)), N in 1 .. Parts] -- - -- with the negative sign if Minus is true. + -- when Parts > 1, with the negative sign if Minus is true. -- -- If no valid real is found, then Ptr.all points either to an initial -- non-blank character, or to Max + 1 if the field is all spaces and the @@ -91,9 +110,9 @@ package System.Value_R is function Value_Raw_Real (Str : String; Base : out Unsigned; - Scale : out Integer; + Scale : out Scale_Array; Extra : out Unsigned; - Minus : out Boolean) return Uns; + Minus : out Boolean) return Value_Array; -- Used in computing X'Value (Str) where X is a real type. Str is the -- string argument of the attribute. Constraint_Error is raised if the -- string is malformed.