blob: 880e9a3c53d3ebb73643e444e0875038f9f7fe0c [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS --
-- --
-- B o d y --
-- --
-- Copyright (C) 2019-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. --
-- --
------------------------------------------------------------------------------
-- 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 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;