path: root/gcc/ada/libgnat/s-valuef.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                       S Y S T E M . V A L U E _ F                        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 2020-2025, 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_F is

   --  The prerequisite of the implementation is that the computation of the
   --  operands of the scaled divide does not unduly overflow, which means
   --  that the numerator and the denominator of the small must be both not
   --  larger than the smallest divide 2**(Int'Size - 1) / Base where Base
   --  ranges over the supported values for the base of the literal, except
   --  when the numerator is 1, in which case up to 2**(Int'Size - 1) is
   --  permitted for the denominator. Given that the largest supported base
   --  is 16, this gives a limit of 2**(Int'Size - 5) in the general case.

   pragma Assert (Int'Size <= Uns'Size);
   --  We need an unsigned type large enough to represent the mantissa

   package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1));
   --  We use the Extra digits for ordinary fixed-point types

   function Integer_To_Fixed
     (Str    : String;
      Val    : Uns;
      Base   : Unsigned;
      ScaleB : Integer;
      Extra2 : Unsigned;
      Minus  : Boolean;
      Num    : Int;
      Den    : Int) return Int;
   --  Convert the real value from integer to fixed point representation

   --  The goal is to compute Val * (Base ** ScaleB) / (Num / Den) with correct
   --  rounding for all decimal values output by Typ'Image, that is to say up
   --  to Typ'Aft decimal digits. Unlike for the output, the RM does not say
   --  what the rounding must be for the input, but a reasonable exegesis of
   --  the intent is that Typ'Value o Typ'Image should be the identity, which
   --  is made possible because 'Aft is defined such that 'Image is injective.

   --  For a type with a mantissa of M bits including the sign, the number N1
   --  of decimal digits required to represent all the numbers is given by:

   --    N1 = ceil ((M - 1) * log 2 / log 10) [N1 = 10/19/39 for M = 32/64/128]

   --  but this mantissa can represent any set of contiguous numbers with only
   --  N2 different decimal digits where:

   --    N2 = floor ((M - 1) * log 2 / log 10) [N2 = 9/18/38 for M = 32/64/128]

   --  Of course N1 = N2 + 1 holds, which means both that Val may not contain
   --  enough significant bits to represent all the values of the type and that
   --  1 extra decimal digit contains the information for the missing bits. But
   --  in practice we need 2 extra decimal digits to avoid multiple roundings.

   --  Therefore the actual computation to be performed is

   --    V = (Val * Base ** 2 + Extra2) * (Base ** (ScaleB - 2)) / (Num / Den)

   --  using two steps of scaled divide if Extra2 is positive and ScaleB too

   --    (1a)  Val * (Den * (Base ** ScaleB)) = Q1 * Num + R1

   --    (2a)  Extra2 * (Den * (Base ** ScaleB)) = Q2 * Base ** 2 + R2

   --  which yields after dividing (1a) by Num and (2a) by Num * (Base ** 2)
   --  and summing

   --    V = Q1 + (Q2 + R1) / Num + R2 / (Num * (Base ** 2))

   --  but we get rid of the third term by using a rounding divide for (2a).

   --  This works only if Den * (Base ** ScaleB) does not overflow for inputs
   --  corresponding to 'Image. Let S = Num / Den, B = Base and N the scale in
   --  base B of S, i.e. the smallest integer such that B**N * S >= 1. Then,
   --  for X a positive of the mantissa, i.e. 1 <= X <= 2**(M-1), we have

   --    1/B <= X * S * B**(N-1) < 2**(M-1)

   --  which means that the inputs corresponding to the output of 'Image have a
   --  ScaleB equal either to 1 - N or (after multiplying the inequality by B)
   --  to -N, possibly after renormalizing X, i.e. multiplying it by a suitable
   --  power of B. Therefore

   --    Den * (Base ** ScaleB) <= Den * (B ** (1 - N)) < Num * B

   --  which means that the product does not overflow if Num <= 2**(M-1) / B.

   --  On the other hand, if Extra2 is positive and ScaleB negative, the above
   --  two steps are

   --   (1b)  Val * Den = Q1 * (Num * (Base ** -ScaleB)) + R1

   --   (2b)  Extra2 * Den = Q2 * Base ** 2 + R2

   --  which yields after dividing (1b) by Num * (Base ** -ScaleB) and (2b) by
   --  Num * (Base ** (2 - ScaleB)) and summing

   --    V = Q1 + (Q2 + R1) / (Num * (Base ** -ScaleB)) + R2 / (Num * (...))

   --  but we get rid of the third term by using a rounding divide for (2b).

   --  This works only if Num * (Base ** -ScaleB) does not overflow for inputs
   --  corresponding to 'Image. With the determination of ScaleB above, we have

   --    Num * (Base ** -ScaleB) <= Num * (B ** N) < Den * B

   --  which means that the product does not overflow if Den <= 2**(M-1) / B.
   --  Moreover, if 2**(M-1) / B < Den <= 2**(M-1), we can add 1 to ScaleB and
   --  divide Val by B while preserving the rightmost B-digit of Val in Extra2
   --  without changing the computation when Num = 1.

   ----------------------
   -- Integer_To_Fixed --
   ----------------------

   function Integer_To_Fixed
     (Str    : String;
      Val    : Uns;
      Base   : Unsigned;
      ScaleB : Integer;
      Extra2 : Unsigned;
      Minus  : Boolean;
      Num    : Int;
      Den    : Int) return Int
   is
      pragma Assert (Base in 2 .. 16);

      pragma Assert (Extra2 < Base ** 2);
      --  Accept only two extra digits after those used for Val

      pragma Assert (Num < 0 and then Den < 0);
      --  Accept only negative numbers to allow -2**(Int'Size - 1)

      pragma Unsuppress (Overflow_Check);
      --  Use overflow check to catch bad values

      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 negative in this context.

      function 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);

         Min : constant Int := Int'First / Base;

         Result : Int := Factor;

      begin
         while Exp > 0 and then Result >= Min loop
            Result := Result * Base;
            Exp    := Exp - 1;
         end loop;

         return Result;
      end Safe_Expont;

      ---------------
      -- To_Signed --
      ---------------

      function 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 To_Signed;

      --  Local variables

      B : constant Int := Int (Base);

      V : Uns      := Val;
      S : Integer  := ScaleB;
      E : Unsigned := Extra2;

      Y, Z, Q1, R1, Q2, R2 : Int;

   begin
      --  The implementation of Value_R uses fully symmetric arithmetics
      --  but here we cannot handle 2**(Int'Size - 1) if Minus is not set.

      if V = 2**(Int'Size - 1) and then not Minus then
         E := Unsigned (V rem Uns (Base)) * Base + E / Base;
         V := V / Uns (Base);
         S := S + 1;
      end if;

      --  We will use a scaled divide operation for which we must control the
      --  magnitude of operands so that an overflow exception is not unduly
      --  raised during the computation. The only real concern is the exponent.

      --  If S is too negative, then drop trailing digits, but preserve the
      --  last two dropped digits, until V saturates to 0.

      if S < 0 then
         declare
            LS : Integer := -S;

         begin
            Y := Den;
            Z := Safe_Expont (B, LS, Num);

            for J in 1 .. LS loop
               if V = 0 then
                  E := 0;
                  exit;
               end if;
               E := Unsigned (V rem Uns (Base)) * Base + E / Base;
               V := V / Uns (Base);
            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, Den);
            Z := Num;

            for J in 1 .. LS loop
               if V <= (Uns'Last - Uns (E / Base)) / Uns (Base) then
                  V := V * Uns (Base) + Uns (E / Base);
                  E := (E rem Base) * Base;
               else
                  Bad_Value (Str);
               end if;
            end loop;
         end;

      --  If S is zero, then proceed directly

      else
         Y := Den;
         Z := Num;
      end if;

      --  Perform a scaled divide operation with final rounding to match Image
      --  using two steps if there is an extra digit available. The second and
      --  third operands are always negative so the sign of the quotient is the
      --  sign of the first operand and the sign of the remainder the opposite.

      if E > 0 then
         Scaled_Divide (To_Signed (V), Y, Z, Q1, R1, Round => False);
         Scaled_Divide (To_Signed (Uns (E)), Y, -B**2, Q2, R2, Round => True);

         --  Avoid an overflow during the subtraction. Note that Q2 is smaller
         --  than Y and R1 smaller than Z in magnitude, so it is safe to take
         --  their absolute value.

         if abs Q2 >= 2 ** (Int'Size - 2)
           or else abs R1 >= 2 ** (Int'Size - 2)
         then
            declare
               Bit : constant Int := Q2 rem 2;

            begin
               Q2 := (Q2 - Bit) / 2;
               R1 := (R1 - Bit) / 2;
               Y  := -2;
            end;

         else
            Y := -1;
         end if;

         Scaled_Divide (Q2 - R1, Y, Z, Q2, R2, Round => True);

         return Q1 + Q2;

      else
         Scaled_Divide (To_Signed (V), Y, Z, Q1, R1, Round => True);

         return Q1;
      end if;

   exception
      when Constraint_Error => Bad_Value (Str);
   end Integer_To_Fixed;

   ----------------
   -- Scan_Fixed --
   ----------------

   function Scan_Fixed
     (Str : String;
      Ptr : not null access Integer;
      Max : Integer;
      Num : Int;
      Den : Int) return Int
   is
      Bas    : Unsigned;
      Scl    : Impl.Scale_Array;
      Extra2 : Unsigned;
      Minus  : Boolean;
      Val    : Impl.Value_Array;

   begin
      Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Bas, Scl, Extra2, Minus);

      return
        Integer_To_Fixed (Str, Val (1), Bas, Scl (1), Extra2, Minus, Num, Den);
   end Scan_Fixed;

   -----------------
   -- Value_Fixed --
   -----------------

   function Value_Fixed
     (Str : String;
      Num : Int;
      Den : Int) return Int
   is
      Bas    : Unsigned;
      Scl    : Impl.Scale_Array;
      Extra2 : Unsigned;
      Minus  : Boolean;
      Val    : Impl.Value_Array;

   begin
      Val := Impl.Value_Raw_Real (Str, Bas, Scl, Extra2, Minus);

      return
        Integer_To_Fixed (Str, Val (1), Bas, Scl (1), Extra2, Minus, Num, Den);
   end Value_Fixed;

end System.Value_F;