------------------------------------------------------------------------------ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- -- ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2019, 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 -- -- . -- -- -- -- 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.Conversions; use Ada.Characters.Conversions; 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 : Optional_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 Optional_Big_Integer; Value : mpz_t_ptr) with Inline; -- Set the mpz_t value stored in Arg to Value procedure Allocate (This : in out Optional_Big_Integer) with Inline; -- Allocate an Optional_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 Optional_Big_Integer; Value : mpz_t_ptr) is begin Arg.Value.C := To_Address (Value); end Set_Mpz; -------------- -- Is_Valid -- -------------- function Is_Valid (Arg : Optional_Big_Integer) return Boolean is (Arg.Value.C /= System.Null_Address); -------------------------- -- Invalid_Big_Integer -- -------------------------- function Invalid_Big_Integer return Optional_Big_Integer is (Value => (Ada.Finalization.Controlled with C => System.Null_Address)); --------- -- "=" -- --------- function "=" (L, R : Big_Integer) return Boolean is begin return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) = 0; end "="; --------- -- "<" -- --------- function "<" (L, R : Big_Integer) return Boolean is begin return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) < 0; end "<"; ---------- -- "<=" -- ---------- function "<=" (L, R : Big_Integer) return Boolean is begin return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) <= 0; end "<="; --------- -- ">" -- --------- function ">" (L, R : Big_Integer) return Boolean is begin return mpz_cmp (Get_Mpz (L), Get_Mpz (R)) > 0; end ">"; ---------- -- ">=" -- ---------- function ">=" (L, R : 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 Big_Integer is Result : Optional_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 : 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 Big_Integer is Result : Optional_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 : 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 Big_Integer is Result : Optional_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 : 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 : 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 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 : Optional_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 (Stream : not null access Ada.Streams.Root_Stream_Type'Class; Arg : Big_Integer) is begin Wide_Wide_String'Write (Stream, To_Wide_Wide_String (To_String (Arg))); end Put_Image; --------- -- "+" -- --------- function "+" (L : Big_Integer) return Big_Integer is Result : Optional_Big_Integer; begin Set_Mpz (Result, new mpz_t); mpz_init_set (Get_Mpz (Result), Get_Mpz (L)); return Result; end "+"; --------- -- "-" -- --------- function "-" (L : Big_Integer) return Big_Integer is Result : Optional_Big_Integer; begin Allocate (Result); mpz_neg (Get_Mpz (Result), Get_Mpz (L)); return Result; end "-"; ----------- -- "abs" -- ----------- function "abs" (L : Big_Integer) return Big_Integer is procedure mpz_abs (ROP : access mpz_t; OP : access constant mpz_t); pragma Import (C, mpz_abs, "__gmpz_abs"); Result : Optional_Big_Integer; begin Allocate (Result); mpz_abs (Get_Mpz (Result), Get_Mpz (L)); return Result; end "abs"; --------- -- "+" -- --------- function "+" (L, R : Big_Integer) return Big_Integer is procedure mpz_add (ROP : access mpz_t; OP1, OP2 : access constant mpz_t); pragma Import (C, mpz_add, "__gmpz_add"); Result : Optional_Big_Integer; begin Allocate (Result); mpz_add (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R)); return Result; end "+"; --------- -- "-" -- --------- function "-" (L, R : Big_Integer) return Big_Integer is Result : Optional_Big_Integer; begin Allocate (Result); mpz_sub (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R)); return Result; end "-"; --------- -- "*" -- --------- function "*" (L, R : Big_Integer) return Big_Integer is procedure mpz_mul (ROP : access mpz_t; OP1, OP2 : access constant mpz_t); pragma Import (C, mpz_mul, "__gmpz_mul"); Result : Optional_Big_Integer; begin Allocate (Result); mpz_mul (Get_Mpz (Result), Get_Mpz (L), Get_Mpz (R)); return Result; end "*"; --------- -- "/" -- --------- function "/" (L, R : Big_Integer) return 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 : Optional_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 : Big_Integer) return 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 : Optional_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 : Big_Integer) return 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 : Optional_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 : Big_Integer; R : Natural) return 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 : Optional_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 : Big_Integer) return Big_Integer is (if L < R then L else R); --------- -- Max -- --------- function Max (L, R : Big_Integer) return Big_Integer is (if L > R then L else R); ----------------------------- -- Greatest_Common_Divisor -- ----------------------------- function Greatest_Common_Divisor (L, R : Big_Integer) return Big_Integer is procedure mpz_gcd (ROP : access mpz_t; Op1, Op2 : access constant mpz_t); pragma Import (C, mpz_gcd, "__gmpz_gcd"); Result : Optional_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 Optional_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;