| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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 -- |
| -- <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 Ada.Unchecked_Deallocation; |
| with Ada.Characters.Conversions; use Ada.Characters.Conversions; |
| |
| with Interfaces; use Interfaces; |
| |
| with System.Generic_Bignums; |
| |
| package body Ada.Numerics.Big_Numbers.Big_Integers is |
| |
| package Bignums is new |
| System.Generic_Bignums (Use_Secondary_Stack => False); |
| use Bignums, System; |
| |
| procedure Free is new Ada.Unchecked_Deallocation (Bignum_Data, Bignum); |
| |
| function Get_Bignum (Arg : Big_Integer) return Bignum is |
| (if Arg.Value.C = System.Null_Address |
| then raise Constraint_Error with "invalid big integer" |
| else To_Bignum (Arg.Value.C)); |
| -- Check for validity of Arg and return the Bignum value stored in Arg. |
| -- Raise Constraint_Error if Arg is uninitialized. |
| |
| procedure Set_Bignum (Arg : out Big_Integer; Value : Bignum) |
| with Inline; |
| -- Set the Bignum value stored in Arg to Value |
| |
| ---------------- |
| -- Set_Bignum -- |
| ---------------- |
| |
| procedure Set_Bignum (Arg : out Big_Integer; Value : Bignum) is |
| begin |
| Arg.Value.C := To_Address (Value); |
| end Set_Bignum; |
| |
| -------------- |
| -- Is_Valid -- |
| -------------- |
| |
| function Is_Valid (Arg : Big_Integer) return Boolean is |
| (Arg.Value.C /= System.Null_Address); |
| |
| --------- |
| -- "=" -- |
| --------- |
| |
| function "=" (L, R : Big_Integer) return Boolean is |
| begin |
| return Big_EQ (Get_Bignum (L), Get_Bignum (R)); |
| end "="; |
| |
| --------- |
| -- "<" -- |
| --------- |
| |
| function "<" (L, R : Big_Integer) return Boolean is |
| begin |
| return Big_LT (Get_Bignum (L), Get_Bignum (R)); |
| end "<"; |
| |
| ---------- |
| -- "<=" -- |
| ---------- |
| |
| function "<=" (L, R : Big_Integer) return Boolean is |
| begin |
| return Big_LE (Get_Bignum (L), Get_Bignum (R)); |
| end "<="; |
| |
| --------- |
| -- ">" -- |
| --------- |
| |
| function ">" (L, R : Big_Integer) return Boolean is |
| begin |
| return Big_GT (Get_Bignum (L), Get_Bignum (R)); |
| end ">"; |
| |
| ---------- |
| -- ">=" -- |
| ---------- |
| |
| function ">=" (L, R : Big_Integer) return Boolean is |
| begin |
| return Big_GE (Get_Bignum (L), Get_Bignum (R)); |
| end ">="; |
| |
| -------------------- |
| -- To_Big_Integer -- |
| -------------------- |
| |
| function To_Big_Integer (Arg : Integer) return Big_Integer is |
| Result : Big_Integer; |
| begin |
| Set_Bignum (Result, To_Bignum (Long_Long_Integer (Arg))); |
| return Result; |
| end To_Big_Integer; |
| |
| ---------------- |
| -- To_Integer -- |
| ---------------- |
| |
| function To_Integer (Arg : Big_Integer) return Integer is |
| begin |
| return Integer (From_Bignum (Get_Bignum (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 : Big_Integer; |
| begin |
| Set_Bignum (Result, To_Bignum (Long_Long_Integer (Arg))); |
| return Result; |
| end To_Big_Integer; |
| |
| ---------------------- |
| -- From_Big_Integer -- |
| ---------------------- |
| |
| function From_Big_Integer (Arg : Big_Integer) return Int is |
| begin |
| return Int (From_Bignum (Get_Bignum (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 : Big_Integer; |
| begin |
| Set_Bignum (Result, To_Bignum (Unsigned_64 (Arg))); |
| return Result; |
| end To_Big_Integer; |
| |
| ---------------------- |
| -- From_Big_Integer -- |
| ---------------------- |
| |
| function From_Big_Integer (Arg : Big_Integer) return Int is |
| begin |
| return Int (From_Bignum (Get_Bignum (Arg))); |
| end From_Big_Integer; |
| |
| end Unsigned_Conversions; |
| |
| --------------- |
| -- To_String -- |
| --------------- |
| |
| Hex_Chars : constant array (0 .. 15) of Character := "0123456789ABCDEF"; |
| |
| function To_String |
| (Arg : Big_Integer; Width : Field := 0; Base : Number_Base := 10) |
| return String |
| is |
| Big_Base : constant Big_Integer := To_Big_Integer (Integer (Base)); |
| |
| 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 (Arg : Big_Integer) return String; |
| -- Return image of Arg, assuming Arg is positive. |
| |
| 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) & "#" & 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; |
| |
| function Image (Arg : Big_Integer) return String is |
| begin |
| if Arg < Big_Base then |
| return (1 => Hex_Chars (To_Integer (Arg))); |
| else |
| return Image (Arg / Big_Base) |
| & Hex_Chars (To_Integer (Arg rem Big_Base)); |
| end if; |
| 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; |
| |
| begin |
| if Arg < To_Big_Integer (0) then |
| return Leading_Padding ("-" & Add_Base (Image (-Arg)), Width); |
| else |
| return Leading_Padding (" " & Add_Base (Image (Arg)), Width); |
| end if; |
| end To_String; |
| |
| ----------------- |
| -- From_String -- |
| ----------------- |
| |
| function From_String (Arg : String) return Big_Integer is |
| Result : Big_Integer; |
| begin |
| -- ??? only support Long_Long_Integer, good enough for now |
| Set_Bignum (Result, To_Bignum (Long_Long_Integer'Value (Arg))); |
| 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 : Big_Integer; |
| begin |
| Set_Bignum (Result, new Bignum_Data'(Get_Bignum (L).all)); |
| return Result; |
| end "+"; |
| |
| --------- |
| -- "-" -- |
| --------- |
| |
| function "-" (L : Big_Integer) return Big_Integer is |
| Result : Big_Integer; |
| begin |
| Set_Bignum (Result, Big_Neg (Get_Bignum (L))); |
| return Result; |
| end "-"; |
| |
| ----------- |
| -- "abs" -- |
| ----------- |
| |
| function "abs" (L : Big_Integer) return Big_Integer is |
| Result : Big_Integer; |
| begin |
| Set_Bignum (Result, Big_Abs (Get_Bignum (L))); |
| return Result; |
| end "abs"; |
| |
| --------- |
| -- "+" -- |
| --------- |
| |
| function "+" (L, R : Big_Integer) return Big_Integer is |
| Result : Big_Integer; |
| begin |
| Set_Bignum (Result, Big_Add (Get_Bignum (L), Get_Bignum (R))); |
| return Result; |
| end "+"; |
| |
| --------- |
| -- "-" -- |
| --------- |
| |
| function "-" (L, R : Big_Integer) return Big_Integer is |
| Result : Big_Integer; |
| begin |
| Set_Bignum (Result, Big_Sub (Get_Bignum (L), Get_Bignum (R))); |
| return Result; |
| end "-"; |
| |
| --------- |
| -- "*" -- |
| --------- |
| |
| function "*" (L, R : Big_Integer) return Big_Integer is |
| Result : Big_Integer; |
| begin |
| Set_Bignum (Result, Big_Mul (Get_Bignum (L), Get_Bignum (R))); |
| return Result; |
| end "*"; |
| |
| --------- |
| -- "/" -- |
| --------- |
| |
| function "/" (L, R : Big_Integer) return Big_Integer is |
| Result : Big_Integer; |
| begin |
| Set_Bignum (Result, Big_Div (Get_Bignum (L), Get_Bignum (R))); |
| return Result; |
| end "/"; |
| |
| ----------- |
| -- "mod" -- |
| ----------- |
| |
| function "mod" (L, R : Big_Integer) return Big_Integer is |
| Result : Big_Integer; |
| begin |
| Set_Bignum (Result, Big_Mod (Get_Bignum (L), Get_Bignum (R))); |
| return Result; |
| end "mod"; |
| |
| ----------- |
| -- "rem" -- |
| ----------- |
| |
| function "rem" (L, R : Big_Integer) return Big_Integer is |
| Result : Big_Integer; |
| begin |
| Set_Bignum (Result, Big_Rem (Get_Bignum (L), Get_Bignum (R))); |
| return Result; |
| end "rem"; |
| |
| ---------- |
| -- "**" -- |
| ---------- |
| |
| function "**" (L : Big_Integer; R : Natural) return Big_Integer is |
| begin |
| -- Explicitly check for validity before allocating Exp so that |
| -- the call to Get_Bignum below cannot raise an exception before |
| -- we get a chance to free Exp. |
| |
| if not Is_Valid (L) then |
| raise Constraint_Error with "invalid big integer"; |
| end if; |
| |
| declare |
| Exp : Bignum := To_Bignum (Long_Long_Integer (R)); |
| Result : Big_Integer; |
| begin |
| Set_Bignum (Result, Big_Exp (Get_Bignum (L), Exp)); |
| Free (Exp); |
| return Result; |
| end; |
| 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_Positive is |
| function GCD (A, B : Big_Integer) return Big_Integer; |
| -- Recursive internal version |
| |
| --------- |
| -- GCD -- |
| --------- |
| |
| function GCD (A, B : Big_Integer) return Big_Integer is |
| begin |
| if Is_Zero (Get_Bignum (B)) then |
| return A; |
| else |
| return GCD (B, A rem B); |
| end if; |
| end GCD; |
| |
| begin |
| return GCD (abs L, abs R); |
| end Greatest_Common_Divisor; |
| |
| ------------ |
| -- Adjust -- |
| ------------ |
| |
| procedure Adjust (This : in out Controlled_Bignum) is |
| begin |
| if This.C /= System.Null_Address then |
| This.C := To_Address (new Bignum_Data'(To_Bignum (This.C).all)); |
| end if; |
| end Adjust; |
| |
| -------------- |
| -- Finalize -- |
| -------------- |
| |
| procedure Finalize (This : in out Controlled_Bignum) is |
| Tmp : Bignum := To_Bignum (This.C); |
| begin |
| Free (Tmp); |
| This.C := System.Null_Address; |
| end Finalize; |
| |
| end Ada.Numerics.Big_Numbers.Big_Integers; |
