| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S Y S T E M . V A L U E _ D -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2020-2022, 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 |
| |
| 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); |
| -- We do not use the Extra digit for decimal fixed-point types |
| |
| 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; |
