diff options
Diffstat (limited to 'gcc/ada/libgnat/s-valued.adb')
| -rw-r--r-- | gcc/ada/libgnat/s-valued.adb | 257 |
1 files changed, 257 insertions, 0 deletions
diff --git a/gcc/ada/libgnat/s-valued.adb b/gcc/ada/libgnat/s-valued.adb new file mode 100644 index 0000000..5fa8a99 --- /dev/null +++ b/gcc/ada/libgnat/s-valued.adb @@ -0,0 +1,257 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, 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.Unsigned_Types; use System.Unsigned_Types; +with System.Val_Util; use System.Val_Util; +with System.Value_R; + +package body System.Value_D is + + package Impl is new Value_R (Uns, Floating => False); + + function Integer_to_Decimal + (Str : String; + Val : Uns; + Base : Unsigned; + ScaleB : Integer; + Minus : Boolean; + Scale : Integer) return Int; + -- Convert the real value from integer to decimal representation + + ------------------------ + -- Integer_to_Decimal -- + ------------------------ + + function Integer_to_Decimal + (Str : String; + Val : Uns; + Base : Unsigned; + ScaleB : Integer; + Minus : Boolean; + Scale : Integer) return Int + is + function Safe_Expont + (Base : Int; + Exp : in out Natural; + Factor : Int) return Int; + -- Return (Base ** Exp) * Factor if the computation does not overflow, + -- or else the number of the form (Base ** K) * Factor with the largest + -- magnitude if the former computation overflows. In both cases, Exp is + -- updated to contain the remaining power in the computation. Note that + -- Factor is expected to be positive in this context. + + function Unsigned_To_Signed (Val : Uns) return Int; + -- Convert an integer value from unsigned to signed representation + + ----------------- + -- Safe_Expont -- + ----------------- + + function Safe_Expont + (Base : Int; + Exp : in out Natural; + Factor : Int) return Int + is + pragma Assert (Base /= 0 and then Factor > 0); + + Max : constant Int := Int'Last / Base; + + Result : Int := Factor; + + begin + while Exp > 0 and then Result <= Max loop + Result := Result * Base; + Exp := Exp - 1; + end loop; + + return Result; + end Safe_Expont; + + ------------------------ + -- Unsigned_To_Signed -- + ------------------------ + + function Unsigned_To_Signed (Val : Uns) return Int is + begin + -- Deal with overflow cases, and also with largest negative number + + if Val > Uns (Int'Last) then + if Minus and then Val = Uns (-(Int'First)) then + return Int'First; + else + Bad_Value (Str); + end if; + + -- Negative values + + elsif Minus then + return -(Int (Val)); + + -- Positive values + + else + return Int (Val); + end if; + end Unsigned_To_Signed; + + begin + -- If the base of the value is 10 or its scaling factor is zero, then + -- add the scales (they are defined in the opposite sense) and apply + -- the result to the value, checking for overflow in the process. + + if Base = 10 or else ScaleB = 0 then + declare + S : Integer := ScaleB + Scale; + V : Uns := Val; + + begin + while S < 0 loop + V := V / 10; + S := S + 1; + end loop; + + while S > 0 loop + if V <= Uns'Last / 10 then + V := V * 10; + S := S - 1; + else + Bad_Value (Str); + end if; + end loop; + + return Unsigned_To_Signed (V); + end; + + -- If the base of the value is not 10, use a scaled divide operation + -- to compute Val * (Base ** ScaleB) * (10 ** Scale). + + else + declare + B : constant Int := Int (Base); + S : constant Integer := ScaleB; + + V : Uns := Val; + + Y, Z, Q, R : Int; + + begin + -- If S is too negative, then drop trailing digits + + if S < 0 then + declare + LS : Integer := -S; + + begin + Y := 10 ** Integer'Max (0, Scale); + Z := Safe_Expont (B, LS, 10 ** Integer'Max (0, -Scale)); + + for J in 1 .. LS loop + V := V / Uns (B); + end loop; + end; + + -- If S is too positive, then scale V up, which may then overflow + + elsif S > 0 then + declare + LS : Integer := S; + + begin + Y := Safe_Expont (B, LS, 10 ** Integer'Max (0, Scale)); + Z := 10 ** Integer'Max (0, -Scale); + + for J in 1 .. LS loop + if V <= Uns'Last / Uns (B) then + V := V * Uns (B); + else + Bad_Value (Str); + end if; + end loop; + end; + + -- The case S equal to zero should have been handled earlier + + else + raise Program_Error; + end if; + + -- Perform a scale divide operation with rounding to match 'Image + + Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q, R, Round => True); + + return Q; + end; + end if; + + exception + when Constraint_Error => Bad_Value (Str); + end Integer_to_Decimal; + + ------------------ + -- Scan_Decimal -- + ------------------ + + function Scan_Decimal + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Scale : Integer) return Int + is + Base : Unsigned; + ScaleB : Integer; + Extra : Unsigned; + Minus : Boolean; + Val : Uns; + + begin + Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus); + + return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale); + end Scan_Decimal; + + ------------------- + -- Value_Decimal -- + ------------------- + + function Value_Decimal (Str : String; Scale : Integer) return Int is + Base : Unsigned; + ScaleB : Integer; + Extra : Unsigned; + Minus : Boolean; + Val : Uns; + + begin + Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus); + + return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale); + end Value_Decimal; + +end System.Value_D; |