libgmpada4-dev 0.0.20131223-1 / usr / share / ada / adainclude / gmpada / gnu_multiple_precision.adb

--    GMPAda, binding to the Ada Language for the GNU MultiPrecision library.
--    Copyright (C) 2007-2013 Nicolas Boulenguez <nicolas.boulenguez@free.fr>
--
--    This program is free software: you can redistribute it and/or modify
--    it under the terms of the GNU General Public License as published by
--    the Free Software Foundation, either version 3 of the License, or
--    (at your option) any later version.
--
--    This program is distributed in the hope that it will be useful,
--    but WITHOUT ANY WARRANTY; without even the implied warranty of
--    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--    GNU General Public License for more details.
--
--    You should have received a copy of the GNU General Public License
--    along with this program.  If not, see <http://www.gnu.org/licenses/>.

with Interfaces.C; use Interfaces.C;
with GMP.Binding; use GMP.Binding;

package body GNU_Multiple_Precision is

   overriding procedure Initialize (Object : in out Big_Integer)
   is
   begin
      Mpz_Init (Object.Value);
   end Initialize;

   overriding procedure Adjust (Object : in out Big_Integer)
   is
      Temp : constant Mpz_T := Object.Value;
   begin
      Mpz_Init_Set (Object.Value, Temp);
   end Adjust;

   overriding procedure Finalize (Object : in out Big_Integer)
      is
   begin
      Mpz_Clear (Object.Value);
   end Finalize;

   overriding function "="  (Left, Right : Big_Integer) return Boolean
   is
   begin
      return Mpz_Cmp (Left.Value, Right.Value) = 0;
   end "=";

   overriding procedure Initialize (Object : in out Big_Rational)
   is
   begin
      Mpq_Init (Object.Value);
   end Initialize;

   overriding procedure Adjust (Object : in out Big_Rational)
   is
      Temp : constant Mpq_T := Object.Value;
   begin
      Mpq_Init (Object.Value);
      Mpq_Set (Object.Value, Temp);
   end Adjust;

   overriding procedure Finalize (Object : in out Big_Rational)
   is
   begin
      Mpq_Clear (Object.Value);
   end Finalize;

   overriding function "=" (Left, Right : in Big_Rational) return Boolean
   is
   begin
      return Mpq_Equal (Left.Value, Right.Value) /= 0;
   end "=";

   procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class;
                   Item   :   out  Big_Rational)
   is
      pragma Unmodified (Item);
      --  Item *is* modified, please no warning.
      --  Does anyone see how to do it in a cleaner way?
   begin
      Mpz_T'Read (Stream, Mpq_Numref (Item.Value).all);
      Mpz_T'Read (Stream, Mpq_Denref (Item.Value).all);
   end Read;

   procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class;
                    Item   : in     Big_Rational)
   is
   begin
      Mpz_T'Write (Stream, Mpq_Numref (Item.Value).all);
      Mpz_T'Write (Stream, Mpq_Denref (Item.Value).all);
   end Write;

   overriding procedure Initialize (Object : in out Big_Float)
   is
   begin
      Mpf_Init (Object.Value);
   end Initialize;

   overriding procedure Adjust (Object : in out Big_Float)
   is
      Temp : constant Mpf_T := Object.Value;
   begin
      Mpf_Init_Set (Object.Value, Temp);
   end Adjust;

   overriding procedure Finalize (Object : in out Big_Float)
   is
   begin
      Mpf_Clear (Object.Value);
   end Finalize;

   overriding function "="  (Left, Right : Big_Float) return Boolean
   is
   begin
      return Mpf_Cmp (Left.Value, Right.Value) = 0;
   end "=";

   procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class;
                   Item   :    out Big_Float)
   is
      Prec : constant unsigned_long := unsigned_long'Input (Stream);
      Exp  : constant long  := long'Input (Stream);
      Z    : Mpz_T := Mpz_T'Input (Stream);
   begin
      Mpf_Init2 (Item.Value, Prec);
      Mpf_Set_Z (Item.Value, Z);
      Mpz_Clear (Z);
      pragma Unreferenced (Z);
      if Exp >= 0 then
         Mpf_Mul_2exp (Item.Value, Item.Value, unsigned_long (Exp));
      else
         Mpf_Div_2exp (Item.Value, Item.Value, unsigned_long (-Exp));
      end if;
   end Read;

   procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class;
                    Item   : in     Big_Float)
   is
      Prec : constant unsigned_long := Mpf_Get_Prec (Item.Value);
      D    : double;
      Exp  : long;
      F    : Mpf_T;
      Z    : Mpz_T;
   begin
      Mpf_Init2 (F, Prec);
      unsigned_long'Write (Stream, Prec);
      Mpf_Get_D_2exp (D, Exp, Item.Value);
      pragma Unreferenced (D);
      Exp := Exp - long (Prec);
      long'Write (Stream, Exp);
      if Exp >= 0 then
         Mpf_Div_2exp (F, Item.Value, unsigned_long (Exp));
      else
         Mpf_Mul_2exp (F, Item.Value, unsigned_long (-Exp));
      end if;
      Mpz_Init (Z);
      Mpz_Set_F (Z, F);
      Mpz_T'Write (Stream, Z);
      Mpf_Clear (F);
      pragma Unreferenced (F);
      Mpz_Clear (Z);
      pragma Unreferenced (Z);
   end Write;

   overriding procedure Initialize (Object : in out Big_Float_Rounded)
   is
   begin
      Mpfr_Init (Object.Value);
   end Initialize;

   --  overriding procedure Adjust (Object : in out Big_Float_Rounded)
   --  is
   --  begin
   --     null;
   --  end Adjust;

   overriding procedure Finalize (Object : in out Big_Float_Rounded)
   is
   begin
      Mpfr_Clear (Object.Value);
   end Finalize;

   --  overriding function "="  (Left, Right : Big_Float_Rounded)
   --                           return Boolean
   --  is
   --  begin
   --     return True;
   --  end "=";

   --  procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class;
   --                  Item   :   out  Big_Float_Rounded)
   --  is
   --  begin
   --     null;
   --  end Read;

   --  procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class;
   --                   Item   : in     Big_Float_Rounded)
   --  is
   --  begin
   --     null;
   --  end Write;

   function Identity (Item : in Character)
                     return Character
   is
   begin
      return Item;
   end Identity;

   function Identity (Item : in Character;
                      Substitute : in Character := ' ')
                     return Character is
      pragma Unreferenced (Substitute);
   begin
      return Item;
   end Identity;

end GNU_Multiple_Precision;