------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                       S Y S T E M . V A L U E _ D                        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 2020-2021, 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;
      pragma Unreferenced (Extra);
      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;
      pragma Unreferenced (Extra);
      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;