path: root/gcc/ada/libgnat/a-nbnbin__gmp.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                  ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--             Copyright (C) 2019-2024, 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.      --
--                                                                          --
------------------------------------------------------------------------------

--  This is the GMP version of this package

with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Interfaces.C;               use Interfaces.C;
with Interfaces.C.Strings;       use Interfaces.C.Strings;
with Ada.Characters.Handling;    use Ada.Characters.Handling;

package body Ada.Numerics.Big_Numbers.Big_Integers is

   use System;

   pragma Linker_Options ("-lgmp");

   type mpz_t is record
      mp_alloc : Integer;
      mp_size  : Integer;
      mp_d     : System.Address;
   end record;
   pragma Convention (C, mpz_t);
   type mpz_t_ptr is access all mpz_t;

   function To_Mpz is new Ada.Unchecked_Conversion (System.Address, mpz_t_ptr);
   function To_Address is new
     Ada.Unchecked_Conversion (mpz_t_ptr, System.Address);

   function Get_Mpz (Arg : Big_Integer) return mpz_t_ptr is
     (To_Mpz (Arg.Value.C));
   --  Return the mpz_t value stored in Arg

   procedure Set_Mpz (Arg : in out Big_Integer; Value : mpz_t_ptr)
     with Inline;
   --  Set the mpz_t value stored in Arg to Value

   procedure Allocate (This : in out Big_Integer) with Inline;
   --  Allocate a Big_Integer, including the underlying mpz

   procedure mpz_init_set (ROP : access mpz_t;  OP : access constant mpz_t);
   pragma Import (C, mpz_init_set, "__gmpz_init_set");

   procedure mpz_set (ROP : access mpz_t;  OP : access constant mpz_t);
   pragma Import (C, mpz_set, "__gmpz_set");

   function mpz_cmp (OP1, OP2 : access constant mpz_t) return Integer;
   pragma Import (C, mpz_cmp, "__gmpz_cmp");

   function mpz_cmp_ui
     (OP1 : access constant mpz_t; OP2 : unsigned_long) return Integer;
   pragma Import (C, mpz_cmp_ui, "__gmpz_cmp_ui");

   procedure mpz_set_si (ROP : access mpz_t; OP : long);
   pragma Import (C, mpz_set_si, "__gmpz_set_si");

   procedure mpz_set_ui (ROP : access mpz_t; OP : unsigned_long);
   pragma Import (C, mpz_set_ui, "__gmpz_set_ui");

   function mpz_get_si (OP : access constant mpz_t) return long;
   pragma Import (C, mpz_get_si, "__gmpz_get_si");

   function mpz_get_ui (OP : access constant mpz_t) return unsigned_long;
   pragma Import (C, mpz_get_ui, "__gmpz_get_ui");

   procedure mpz_neg (ROP : access mpz_t;  OP : access constant mpz_t);
   pragma Import (C, mpz_neg, "__gmpz_neg");

   procedure mpz_sub (ROP : access mpz_t;  OP1, OP2 : access constant mpz_t);
   pragma Import (C, mpz_sub, "__gmpz_sub");

   -------------
   -- Set_Mpz --
   -------------

   procedure Set_Mpz (Arg : in out Big_Integer; Value : mpz_t_ptr) is
   begin
      Arg.Value.C := To_Address (Value);
   end Set_Mpz;

   --------------
   -- Is_Valid --
   --------------

   function Is_Valid (Arg : Big_Integer) return Boolean is
     (Arg.Value.C /= System.Null_Address);

   ---------
   -- "=" --
   ---------

   function "=" (L, R : Valid_Big_Integer) return Boolean is
   begin
      return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) = 0;
   end "=";

   ---------
   -- "<" --
   ---------

   function "<" (L, R : Valid_Big_Integer) return Boolean is
   begin
      return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) < 0;
   end "<";

   ----------
   -- "<=" --
   ----------

   function "<=" (L, R : Valid_Big_Integer) return Boolean is
   begin
      return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) <= 0;
   end "<=";

   ---------
   -- ">" --
   ---------

   function ">" (L, R : Valid_Big_Integer) return Boolean is
   begin
      return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) > 0;
   end ">";

   ----------
   -- ">=" --
   ----------

   function ">=" (L, R : Valid_Big_Integer) return Boolean is
   begin
      return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) >= 0;
   end ">=";

   --------------------
   -- To_Big_Integer --
   --------------------

   function To_Big_Integer (Arg : Integer) return Valid_Big_Integer is
      Result : Big_Integer;
   begin
      Allocate (Result);
      mpz_set_si (Get_Mpz (Result), long (Arg));
      return Result;
   end To_Big_Integer;

   ----------------
   -- To_Integer --
   ----------------

   function To_Integer (Arg : Valid_Big_Integer) return Integer is
   begin
      return Integer (mpz_get_si (Get_Mpz (Arg)));
   end To_Integer;

   ------------------------
   -- Signed_Conversions --
   ------------------------

   package body Signed_Conversions is

      --------------------
      -- To_Big_Integer --
      --------------------

      function To_Big_Integer (Arg : Int) return Valid_Big_Integer is
         Result : Big_Integer;
      begin
         Allocate (Result);
         mpz_set_si (Get_Mpz (Result), long (Arg));
         return Result;
      end To_Big_Integer;

      ----------------------
      -- From_Big_Integer --
      ----------------------

      function From_Big_Integer (Arg : Valid_Big_Integer) return Int is
      begin
         return Int (mpz_get_si (Get_Mpz (Arg)));
      end From_Big_Integer;

   end Signed_Conversions;

   --------------------------
   -- Unsigned_Conversions --
   --------------------------

   package body Unsigned_Conversions is

      --------------------
      -- To_Big_Integer --
      --------------------

      function To_Big_Integer (Arg : Int) return Valid_Big_Integer is
         Result : Big_Integer;
      begin
         Allocate (Result);
         mpz_set_ui (Get_Mpz (Result), unsigned_long (Arg));
         return Result;
      end To_Big_Integer;

      ----------------------
      -- From_Big_Integer --
      ----------------------

      function From_Big_Integer (Arg : Valid_Big_Integer) return Int is
      begin
         return Int (mpz_get_ui (Get_Mpz (Arg)));
      end From_Big_Integer;

   end Unsigned_Conversions;

   ---------------
   -- To_String --
   ---------------

   function To_String
     (Arg : Valid_Big_Integer; Width : Field := 0; Base : Number_Base := 10)
      return String
   is
      function mpz_get_str
        (STR  : System.Address;
         BASE : Integer;
         OP   : access constant mpz_t) return chars_ptr;
      pragma Import (C, mpz_get_str, "__gmpz_get_str");

      function mpz_sizeinbase
         (this : access constant mpz_t; base : Integer) return size_t;
      pragma Import (C, mpz_sizeinbase, "__gmpz_sizeinbase");

      function Add_Base (S : String) return String;
      --  Add base information if Base /= 10

      function Leading_Padding
        (Str        : String;
         Min_Length : Field;
         Char       : Character := ' ') return String;
      --  Return padding of Char concatenated with Str so that the resulting
      --  string is at least Min_Length long.

      function Image (N : Natural) return String;
      --  Return image of N, with no leading space.

      --------------
      -- Add_Base --
      --------------

      function Add_Base (S : String) return String is
      begin
         if Base = 10 then
            return S;
         else
            return Image (Base) & "#" & To_Upper (S) & "#";
         end if;
      end Add_Base;

      -----------
      -- Image --
      -----------

      function Image (N : Natural) return String is
         S : constant String := Natural'Image (N);
      begin
         return S (2 .. S'Last);
      end Image;

      ---------------------
      -- Leading_Padding --
      ---------------------

      function Leading_Padding
        (Str        : String;
         Min_Length : Field;
         Char       : Character := ' ') return String is
      begin
         return (1 .. Integer'Max (Integer (Min_Length) - Str'Length, 0)
                        => Char) & Str;
      end Leading_Padding;

      Number_Digits : constant Integer :=
        Integer (mpz_sizeinbase (Get_Mpz (Arg), Integer (abs Base)));

      Buffer : aliased String (1 .. Number_Digits + 2);
      --  The correct number to allocate is 2 more than Number_Digits in order
      --  to handle a possible minus sign and the null-terminator.

      Result : constant chars_ptr :=
        mpz_get_str (Buffer'Address, Integer (Base), Get_Mpz (Arg));
      S      : constant String := Value (Result);

   begin
      if S (1) = '-' then
         return Leading_Padding ("-" & Add_Base (S (2 .. S'Last)), Width);
      else
         return Leading_Padding (" " & Add_Base (S), Width);
      end if;
   end To_String;

   -----------------
   -- From_String --
   -----------------

   function From_String (Arg : String) return Valid_Big_Integer is
      function mpz_set_str
        (this : access mpz_t;
         str  : System.Address;
         base : Integer := 10) return Integer;
      pragma Import (C, mpz_set_str, "__gmpz_set_str");

      Result : Big_Integer;
      First  : Natural;
      Last   : Natural;
      Base   : Natural;

   begin
      Allocate (Result);

      if Arg (Arg'Last) /= '#' then

         --  Base 10 number

         First := Arg'First;
         Last  := Arg'Last;
         Base  := 10;
      else
         --  Compute the xx base in a xx#yyyyy# number

         if Arg'Length < 4 then
            raise Constraint_Error;
         end if;

         First := 0;
         Last  := Arg'Last - 1;

         for J in Arg'First + 1 .. Last loop
            if Arg (J) = '#' then
               First := J;
               exit;
            end if;
         end loop;

         if First = 0 then
            raise Constraint_Error;
         end if;

         Base  := Natural'Value (Arg (Arg'First .. First - 1));
         First := First + 1;
      end if;

      declare
         Str   : aliased String (1 .. Last - First + 2);
         Index : Natural := 0;
      begin
         --  Strip underscores

         for J in First .. Last loop
            if Arg (J) /= '_' then
               Index := Index + 1;
               Str (Index) := Arg (J);
            end if;
         end loop;

         Index := Index + 1;
         Str (Index) := ASCII.NUL;

         if mpz_set_str (Get_Mpz (Result), Str'Address, Base) /= 0 then
            raise Constraint_Error;
         end if;
      end;

      return Result;
   end From_String;

   ---------------
   -- Put_Image --
   ---------------

   procedure Put_Image (S : in out Root_Buffer_Type'Class; V : Big_Integer) is
      --  This is implemented in terms of To_String. It might be more elegant
      --  and more efficient to do it the other way around, but this is the
      --  most expedient implementation for now.
   begin
      Strings.Text_Buffers.Put_UTF_8 (S, To_String (V));
   end Put_Image;

   ---------
   -- "+" --
   ---------

   function "+" (L : Valid_Big_Integer) return Valid_Big_Integer is
      Result : Big_Integer;
   begin
      Set_Mpz (Result, new mpz_t);
      mpz_init_set (Get_Mpz (Result), Get_Mpz (L));
      return Result;
   end "+";

   ---------
   -- "-" --
   ---------

   function "-" (L : Valid_Big_Integer) return Valid_Big_Integer is
      Result : Big_Integer;
   begin
      Allocate (Result);
      mpz_neg (Get_Mpz (Result), Get_Mpz (L));
      return Result;
   end "-";

   -----------
   -- "abs" --
   -----------

   function "abs" (L : Valid_Big_Integer) return Valid_Big_Integer is
      procedure mpz_abs (ROP : access mpz_t;  OP : access constant mpz_t);
      pragma Import (C, mpz_abs, "__gmpz_abs");

      Result : Big_Integer;
   begin
      Allocate (Result);
      mpz_abs (Get_Mpz (Result), Get_Mpz (L));
      return Result;
   end "abs";

   ---------
   -- "+" --
   ---------

   function "+" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
      procedure mpz_add
        (ROP : access mpz_t;  OP1, OP2 : access constant mpz_t);
      pragma Import (C, mpz_add, "__gmpz_add");

      Result : Big_Integer;

   begin
      Allocate (Result);
      mpz_add (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R));
      return Result;
   end "+";

   ---------
   -- "-" --
   ---------

   function "-" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
      Result : Big_Integer;
   begin
      Allocate (Result);
      mpz_sub (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R));
      return Result;
   end "-";

   ---------
   -- "*" --
   ---------

   function "*" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
      procedure mpz_mul
        (ROP : access mpz_t;  OP1, OP2 : access constant mpz_t);
      pragma Import (C, mpz_mul, "__gmpz_mul");

      Result : Big_Integer;

   begin
      Allocate (Result);
      mpz_mul (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R));
      return Result;
   end "*";

   ---------
   -- "/" --
   ---------

   function "/" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
      procedure mpz_tdiv_q (Q : access mpz_t;  N, D : access constant mpz_t);
      pragma Import (C, mpz_tdiv_q, "__gmpz_tdiv_q");
   begin
      if mpz_cmp_ui (Get_Mpz (R), 0) = 0 then
         raise Constraint_Error;
      end if;

      declare
         Result : Big_Integer;
      begin
         Allocate (Result);
         mpz_tdiv_q (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R));
         return Result;
      end;
   end "/";

   -----------
   -- "mod" --
   -----------

   function "mod" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
      procedure mpz_mod (R : access mpz_t;  N, D : access constant mpz_t);
      pragma Import (C, mpz_mod, "__gmpz_mod");
      --  result is always non-negative

      L_Negative, R_Negative : Boolean;

   begin
      if mpz_cmp_ui (Get_Mpz (R), 0) = 0 then
         raise Constraint_Error;
      end if;

      declare
         Result : Big_Integer;
      begin
         Allocate (Result);
         L_Negative := mpz_cmp_ui (Get_Mpz (L), 0) < 0;
         R_Negative := mpz_cmp_ui (Get_Mpz (R), 0) < 0;

         if not (L_Negative or R_Negative) then
            mpz_mod (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R));
         else
            --  The GMP library provides operators defined by C semantics, but
            --  the semantics of Ada's mod operator are not the same as C's
            --  when negative values are involved. We do the following to
            --  implement the required Ada semantics.

            declare
               Temp_Left   : Big_Integer;
               Temp_Right  : Big_Integer;
               Temp_Result : Big_Integer;

            begin
               Allocate (Temp_Result);
               Set_Mpz (Temp_Left, new mpz_t);
               Set_Mpz (Temp_Right, new mpz_t);
               mpz_init_set (Get_Mpz (Temp_Left), Get_Mpz (L));
               mpz_init_set (Get_Mpz (Temp_Right), Get_Mpz (R));

               if L_Negative then
                  mpz_neg (Get_Mpz (Temp_Left), Get_Mpz (Temp_Left));
               end if;

               if R_Negative then
                  mpz_neg (Get_Mpz (Temp_Right), Get_Mpz (Temp_Right));
               end if;

               --  now both Temp_Left and Temp_Right are nonnegative

               mpz_mod (Get_Mpz (Temp_Result),
                        Get_Mpz (Temp_Left),
                        Get_Mpz (Temp_Right));

               if mpz_cmp_ui (Get_Mpz (Temp_Result), 0) = 0 then
                  --  if Temp_Result is zero we are done
                  mpz_set (Get_Mpz (Result), Get_Mpz (Temp_Result));

               elsif L_Negative then
                  if R_Negative then
                     mpz_neg (Get_Mpz (Result), Get_Mpz (Temp_Result));
                  else -- L is negative but R is not
                     mpz_sub (Get_Mpz (Result),
                              Get_Mpz (Temp_Right),
                              Get_Mpz (Temp_Result));
                  end if;
               else
                  pragma Assert (R_Negative);
                  mpz_sub (Get_Mpz (Result),
                           Get_Mpz (Temp_Result),
                           Get_Mpz (Temp_Right));
               end if;
            end;
         end if;

         return Result;
      end;
   end "mod";

   -----------
   -- "rem" --
   -----------

   function "rem" (L, R : Valid_Big_Integer) return Valid_Big_Integer is
      procedure mpz_tdiv_r (R : access mpz_t;  N, D : access constant mpz_t);
      pragma Import (C, mpz_tdiv_r, "__gmpz_tdiv_r");
      --   R will have the same sign as N.

   begin
      if mpz_cmp_ui (Get_Mpz (R), 0) = 0 then
         raise Constraint_Error;
      end if;

      declare
         Result : Big_Integer;
      begin
         Allocate (Result);
         mpz_tdiv_r (R => Get_Mpz (Result),
                     N => Get_Mpz (L),
                     D => Get_Mpz (R));
         --  the result takes the sign of N, as required by the RM

         return Result;
      end;
   end "rem";

   ----------
   -- "**" --
   ----------

   function "**"
     (L : Valid_Big_Integer; R : Natural) return Valid_Big_Integer
   is
      procedure mpz_pow_ui (ROP : access mpz_t;
                            BASE : access constant mpz_t;
                            EXP : unsigned_long);
      pragma Import (C, mpz_pow_ui, "__gmpz_pow_ui");

      Result : Big_Integer;

   begin
      Allocate (Result);
      mpz_pow_ui (Get_Mpz (Result), Get_Mpz (L), unsigned_long (R));
      return Result;
   end "**";

   ---------
   -- Min --
   ---------

   function Min (L, R : Valid_Big_Integer) return Valid_Big_Integer is
     (if L < R then L else R);

   ---------
   -- Max --
   ---------

   function Max (L, R : Valid_Big_Integer) return Valid_Big_Integer is
     (if L > R then L else R);

   -----------------------------
   -- Greatest_Common_Divisor --
   -----------------------------

   function Greatest_Common_Divisor
     (L, R : Valid_Big_Integer) return Big_Positive
   is
      procedure mpz_gcd
        (ROP : access mpz_t;  Op1, Op2 : access constant mpz_t);
      pragma Import (C, mpz_gcd, "__gmpz_gcd");

      Result : Big_Integer;

   begin
      Allocate (Result);
      mpz_gcd (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R));
      return Result;
   end Greatest_Common_Divisor;

   --------------
   -- Allocate --
   --------------

   procedure Allocate (This : in out Big_Integer) is
      procedure mpz_init (this : access mpz_t);
      pragma Import (C, mpz_init, "__gmpz_init");
   begin
      Set_Mpz (This, new mpz_t);
      mpz_init (Get_Mpz (This));
   end Allocate;

   ------------
   -- Adjust --
   ------------

   procedure Adjust (This : in out Controlled_Bignum) is
      Value : constant mpz_t_ptr := To_Mpz (This.C);
   begin
      if Value /= null then
         This.C := To_Address (new mpz_t);
         mpz_init_set (To_Mpz (This.C), Value);
      end if;
   end Adjust;

   --------------
   -- Finalize --
   --------------

   procedure Finalize (This : in out Controlled_Bignum) is
      procedure Free is new Ada.Unchecked_Deallocation (mpz_t, mpz_t_ptr);

      procedure mpz_clear (this : access mpz_t);
      pragma Import (C, mpz_clear, "__gmpz_clear");

      Mpz : mpz_t_ptr;

   begin
      if This.C /= System.Null_Address then
         Mpz := To_Mpz (This.C);
         mpz_clear (Mpz);
         Free (Mpz);
         This.C := System.Null_Address;
      end if;
   end Finalize;

end Ada.Numerics.Big_Numbers.Big_Integers;