diff gcc/ada/libgnat/a-nbnbin.adb @ 145:1830386684a0

gcc-9.2.0
author anatofuz
date Thu, 13 Feb 2020 11:34:05 +0900
parents
children
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/ada/libgnat/a-nbnbin.adb	Thu Feb 13 11:34:05 2020 +0900
@@ -0,0 +1,484 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         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;