729 lines
21 KiB
Ada
729 lines
21 KiB
Ada
|
------------------------------------------------------------------------------
|
||
|
|
-- --
|
||
|
|
-- GNAT RUN-TIME COMPONENTS --
|
||
|
|
-- --
|
||
|
|
-- ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS --
|
||
|
|
-- --
|
||
|
|
-- B o d y --
|
||
|
|
-- --
|
||
|
|
-- Copyright (C) 2019-2020, 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.Strings.Text_Output.Utils;
|
||
|
|
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 Sink'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_Output.Utils.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;
|