------------------------------------------------------------------------------ -- -- -- 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 -- -- . -- -- -- -- 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 Interfaces; use Interfaces; with System.Generic_Bignums; with System.Shared_Bignums; use System.Shared_Bignums; package body Ada.Numerics.Big_Numbers.Big_Integers is function Allocate_Bignum (D : Digit_Vector; Neg : Boolean) return Bignum; -- Allocate Bignum value with the given contents procedure Free_Bignum (X : in out Bignum); -- Free memory associated with X function To_Bignum (X : aliased in out Bignum) return Bignum is (X); procedure Free is new Ada.Unchecked_Deallocation (Bignum_Data, Bignum); --------------------- -- Allocate_Bignum -- --------------------- function Allocate_Bignum (D : Digit_Vector; Neg : Boolean) return Bignum is begin return new Bignum_Data'(D'Length, Neg, D); end Allocate_Bignum; ----------------- -- Free_Bignum -- ----------------- procedure Free_Bignum (X : in out Bignum) is begin Free (X); end Free_Bignum; package Bignums is new System.Generic_Bignums (Bignum, Allocate_Bignum, Free_Bignum, To_Bignum); use System, Bignums; subtype Bignum is Bignums.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 : Valid_Big_Integer) return Boolean is begin return Big_EQ (Get_Bignum (L), Get_Bignum (R)); end "="; --------- -- "<" -- --------- function "<" (L, R : Valid_Big_Integer) return Boolean is begin return Big_LT (Get_Bignum (L), Get_Bignum (R)); end "<"; ---------- -- "<=" -- ---------- function "<=" (L, R : Valid_Big_Integer) return Boolean is begin return Big_LE (Get_Bignum (L), Get_Bignum (R)); end "<="; --------- -- ">" -- --------- function ">" (L, R : Valid_Big_Integer) return Boolean is begin return Big_GT (Get_Bignum (L), Get_Bignum (R)); end ">"; ---------- -- ">=" -- ---------- function ">=" (L, R : Valid_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 Valid_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 : Valid_Big_Integer) return Integer is begin return Integer (Long_Long_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 Valid_Big_Integer is Result : Big_Integer; begin Set_Bignum (Result, To_Bignum (Long_Long_Long_Integer (Arg))); return Result; end To_Big_Integer; ---------------------- -- From_Big_Integer -- ---------------------- function From_Big_Integer (Arg : Valid_Big_Integer) return Int is begin return Int (Long_Long_Long_Integer'(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 Valid_Big_Integer is Result : Big_Integer; begin Set_Bignum (Result, To_Bignum (Unsigned_128 (Arg))); return Result; end To_Big_Integer; ---------------------- -- From_Big_Integer -- ---------------------- function From_Big_Integer (Arg : Valid_Big_Integer) return Int is begin return Int (Unsigned_128'(From_Bignum (Get_Bignum (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 begin return To_String (Get_Bignum (Arg), Natural (Width), Positive (Base)); end To_String; ----------------- -- From_String -- ----------------- function From_String (Arg : String) return Valid_Big_Integer is procedure Scan_Decimal (Arg : String; J : in out Natural; Result : out Big_Integer); -- Scan decimal value starting at Arg (J). Store value in Result if -- successful, raise Constraint_Error if not. On exit, J points to the -- first index past the decimal value. ------------------ -- Scan_Decimal -- ------------------ procedure Scan_Decimal (Arg : String; J : in out Natural; Result : out Big_Integer) is Initial_J : constant Natural := J; Ten : constant Big_Integer := To_Big_Integer (10); begin Result := To_Big_Integer (0); while J <= Arg'Last loop if Arg (J) in '0' .. '9' then Result := Result * Ten + To_Big_Integer (Character'Pos (Arg (J)) - Character'Pos ('0')); elsif Arg (J) = '_' then if J in Initial_J | Arg'Last or else Arg (J - 1) not in '0' .. '9' or else Arg (J + 1) not in '0' .. '9' then raise Constraint_Error with "invalid integer value: " & Arg; end if; else exit; end if; J := J + 1; end loop; end Scan_Decimal; Result : Big_Integer; begin -- First try the fast path via Long_Long_Long_Integer'Value Set_Bignum (Result, To_Bignum (Long_Long_Long_Integer'Value (Arg))); return Result; exception when Constraint_Error => -- Then try the slow path declare Neg : Boolean := False; Base_Found : Boolean := False; Base_Int : Positive := 10; J : Natural := Arg'First; Val : Natural; Base : Big_Integer; Exp : Big_Integer; begin -- Scan past leading blanks while J <= Arg'Last and then Arg (J) = ' ' loop J := J + 1; end loop; if J > Arg'Last then raise; end if; -- Scan and store negative sign if found if Arg (J) = '-' then Neg := True; J := J + 1; end if; -- Scan decimal value: either the result itself, or the base -- value if followed by a '#'. Scan_Decimal (Arg, J, Result); -- Scan explicit base if requested if J <= Arg'Last and then Arg (J) = '#' then Base_Int := To_Integer (Result); if Base_Int not in 2 .. 16 then raise; end if; Base_Found := True; Base := Result; Result := To_Big_Integer (0); J := J + 1; while J <= Arg'Last loop case Arg (J) is when '0' .. '9' => Val := Character'Pos (Arg (J)) - Character'Pos ('0'); if Val >= Base_Int then raise; end if; Result := Result * Base + To_Big_Integer (Val); when 'a' .. 'f' => Val := 10 + Character'Pos (Arg (J)) - Character'Pos ('a'); if Val >= Base_Int then raise; end if; Result := Result * Base + To_Big_Integer (Val); when 'A' .. 'F' => Val := 10 + Character'Pos (Arg (J)) - Character'Pos ('A'); if Val >= Base_Int then raise; end if; Result := Result * Base + To_Big_Integer (Val); when '_' => -- We only allow _ preceded and followed by a valid -- number and not any other character. if J in Arg'First | Arg'Last or else Arg (J - 1) in '_' | '#' or else Arg (J + 1) = '#' then raise; end if; when '#' => J := J + 1; exit; when others => raise; end case; J := J + 1; end loop; else Base := To_Big_Integer (10); end if; if Base_Found and then Arg (J - 1) /= '#' then raise; end if; if J <= Arg'Last then -- Scan exponent if Arg (J) in 'e' | 'E' then J := J + 1; if Arg (J) = '+' then J := J + 1; end if; Scan_Decimal (Arg, J, Exp); Result := Result * (Base ** To_Integer (Exp)); end if; -- Scan past trailing blanks while J <= Arg'Last and then Arg (J) = ' ' loop J := J + 1; end loop; if J <= Arg'Last then raise; end if; end if; if Neg then return -Result; else return Result; end if; end; 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_Bignum (Result, new Bignum_Data'(Get_Bignum (L).all)); return Result; end "+"; --------- -- "-" -- --------- function "-" (L : Valid_Big_Integer) return Valid_Big_Integer is Result : Big_Integer; begin Set_Bignum (Result, Big_Neg (Get_Bignum (L))); return Result; end "-"; ----------- -- "abs" -- ----------- function "abs" (L : Valid_Big_Integer) return Valid_Big_Integer is Result : Big_Integer; begin Set_Bignum (Result, Big_Abs (Get_Bignum (L))); return Result; end "abs"; --------- -- "+" -- --------- function "+" (L, R : Valid_Big_Integer) return Valid_Big_Integer is Result : Big_Integer; begin Set_Bignum (Result, Big_Add (Get_Bignum (L), Get_Bignum (R))); return Result; end "+"; --------- -- "-" -- --------- function "-" (L, R : Valid_Big_Integer) return Valid_Big_Integer is Result : Big_Integer; begin Set_Bignum (Result, Big_Sub (Get_Bignum (L), Get_Bignum (R))); return Result; end "-"; --------- -- "*" -- --------- function "*" (L, R : Valid_Big_Integer) return Valid_Big_Integer is Result : Big_Integer; begin Set_Bignum (Result, Big_Mul (Get_Bignum (L), Get_Bignum (R))); return Result; end "*"; --------- -- "/" -- --------- function "/" (L, R : Valid_Big_Integer) return Valid_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 : Valid_Big_Integer) return Valid_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 : Valid_Big_Integer) return Valid_Big_Integer is Result : Big_Integer; begin Set_Bignum (Result, Big_Rem (Get_Bignum (L), Get_Bignum (R))); return Result; end "rem"; ---------- -- "**" -- ---------- function "**" (L : Valid_Big_Integer; R : Natural) return Valid_Big_Integer is begin 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 : 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 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;