--    GMPAda, binding to the Ada Language for the GNU MultiPrecision library.
--    Copyright (C) 2007-2011 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 Ada.IO_Exceptions;
with Ada.Unchecked_Deallocation;

package body GNU_Multiple_Precision.Aux is

   type Char_Array_Access is access char_array;
   procedure Free is new Ada.Unchecked_Deallocation (char_array,
                                                     Char_Array_Access);
   --  Since we will allocate huge buffers, we have to allocate on the
   --  heap to avoid stack overflow.

   function Is_Digit (Item : Character;
                      Base : int)
                     return Boolean
   is
   begin
      case Item is
         when '0' .. '9' =>
            return Character'Pos (Item) - Character'Pos ('0') < Base;
         when 'A' .. 'F' =>
            return Character'Pos (Item) - Character'Pos ('A') + 10 < Base;
         when 'a' .. 'f' =>
            return Character'Pos (Item) - Character'Pos ('a') + 10 < Base;
         when others =>
            return False;
      end case;
   end Is_Digit;

   function Is_Blank (Item : Character) return Boolean
   is
   begin
      return Item = ' ' or Item = ASCII.HT;
   end Is_Blank;

   procedure Put
     (Put_Character : access procedure (Item : in Character);
      Item          : in Mpz_T;
      Width         : in Natural;
      Base          : in Integer)
   is
      Buffer   : Char_Array_Access
        := new char_array (0 .. Mpz_Sizeinbase (Item, int (Base)) + 1);
      Length   : size_t
        := Buffer'Last - 2; --  no sign and mpz_sizeinbase overestimated
      Negative : Boolean;
   begin
      Mpz_Get_Str (Buffer.all, int (Base), Item);
      Negative := To_Ada (Buffer.all (0)) = '-';
      while Buffer.all (Length) /= nul loop
         Length := Length + 1;
      end loop;
      case Base is
         when 2 .. 9 =>
            for I in Natural (Length) + 4 .. Width loop
               Put_Character.all (' ');
            end loop;
            if Negative then Put_Character.all ('-'); end if;
            Put_Character.all (Character'Val (Base + Character'Pos ('0')));
            Put_Character.all ('#');
         when 10 =>
            for I in Natural (Length) + 1 .. Width loop
               Put_Character.all (' ');
            end loop;
            if Negative then Put_Character.all ('-'); end if;
         when 11 .. 16 =>
            for I in Natural (Length) + 5 .. Width loop
               Put_Character.all (' ');
            end loop;
            if Negative then Put_Character.all ('-'); end if;
            Put_Character.all ('1');
            Put_Character.all (Character'Val
                                 (Base - 10 + Character'Pos ('0')));
            Put_Character.all ('#');
         when others =>
            null;
            pragma Assert (False);
      end case;
      if Negative then
         for I in 1 .. Length - 1 loop
            Put_Character.all (To_Ada (Buffer.all (I)));
         end loop;
      else
         for I in 0 .. Length - 1 loop
            Put_Character.all (To_Ada (Buffer.all (I)));
         end loop;
      end if;
      if Base /= 10 then
         Put_Character.all ('#');
      end if;
      Free (Buffer);
   exception
      when others =>
         Free (Buffer);
         raise;
   end Put;

   procedure Put
     (Put_Character : access procedure (Item : in Character);
      Item          : in Mpq_T;
      Width         : in Natural;
      Base          : in Integer)
   is
      Buffer : Char_Array_Access := new char_array
        (0 .. Mpz_Sizeinbase (Mpq_Numref (Item).all, int (Base))
         + Mpz_Sizeinbase (Mpq_Denref (Item).all, int (Base)) + 2);
      Length : size_t := Buffer'Last - 4;
      --  no sign, no slash and both mpz_sizeinbase overestimated
      Negative : Boolean;
   begin
      Mpq_Get_Str (Buffer.all, int (Base), Item);
      Negative := To_Ada (Buffer.all (0)) = '-';
      while Buffer.all (Length) /= nul loop
         Length := Length + 1;
      end loop;
      case Base is
         when 2 .. 9 =>
            for I in Natural (Length) + 4 .. Width loop
               Put_Character.all (' ');
            end loop;
            if Negative then Put_Character.all ('-'); end if;
            Put_Character.all (Character'Val (Base + Character'Pos ('0')));
            Put_Character.all ('#');
         when 10 =>
            for I in Natural (Length) + 1 .. Width loop
               Put_Character.all (' ');
            end loop;
            if Negative then Put_Character.all ('-'); end if;
         when 11 .. 16 =>
            for I in Natural (Length) + 5 .. Width loop
               Put_Character.all (' ');
            end loop;
            if Negative then Put_Character.all ('-'); end if;
            Put_Character.all ('1');
            Put_Character.all (Character'Val
                                 (Base - 10 + Character'Pos ('0')));
            Put_Character.all ('#');
         when others =>
            null;
            pragma Assert (False);
      end case;
      if Negative then
         for I in 1 .. Length - 1 loop
            Put_Character.all (To_Ada (Buffer.all (I)));
         end loop;
      else
         for I in 0 .. Length - 1 loop
            Put_Character.all (To_Ada (Buffer.all (I)));
         end loop;
      end if;
      if Base /= 10 then
         Put_Character.all ('#');
      end if;
      Free (Buffer);
   exception
      when others =>
         Free (Buffer);
         raise;
   end Put;

   procedure Put
     (Put_Character : access procedure (Item : in Character);
      Item          : in Mpf_T;
      Fore          : in Natural;
      Aft           : in Natural;
      Exp           : in Natural)
   is
      Actual_Fore : constant Natural := Natural'Max (1, Fore);
      Actual_Aft  : constant Natural := Natural'Max (1, Aft);
      Next_In     : size_t := 1;
      Exponent    : Mp_Exp_T;
      procedure Copy (Buffer : in char_array);
      procedure Blank_And_Sign (Buffer      : in char_array;
                                Filled_Fore : in Natural);
      pragma Inline (Copy);
      procedure Copy (Buffer : in char_array)
      is
      begin
         if Buffer (Next_In) = nul then
            Put_Character.all ('0');
         else
            pragma Assert (To_Ada (Buffer (Next_In)) in '0' .. '9'
                           or To_Ada (Buffer (Next_In)) = '-');
            Put_Character.all (To_Ada (Buffer (Next_In)));
            Next_In := Next_In + 1;
         end if;
      end Copy;
      procedure Blank_And_Sign (Buffer      : in char_array;
                                Filled_Fore : in Natural)
      is
      begin
         if Buffer (Buffer'First) = To_C ('-') then
            for I in Filled_Fore + 2 .. Actual_Fore loop
               Put_Character.all (' ');
            end loop;
            Copy (Buffer);
         else
            for I in Filled_Fore + 1 .. Actual_Fore loop
               Put_Character.all (' ');
            end loop;
         end if;
      end Blank_And_Sign;
   begin
      if Exp > 0 then
         declare
            Buffer : Char_Array_Access
              := new char_array (1 .. size_t (Actual_Fore + Actual_Aft) + 2);
            --  2 for sign and nul
         begin
            Mpf_Get_Str (Buffer.all, Exponent, 10, Buffer'Length - 2, Item);
            Blank_And_Sign (Buffer.all, 1);
            if Buffer.all (Next_In) /= nul then
               Exponent := Exponent - 1;
            end if;
            Copy (Buffer.all);
            Put_Character.all ('.');
            for I in 1 .. Actual_Aft loop Copy (Buffer.all); end loop;
            Put_Character.all ('E');
            declare
               E_Img : String := Mp_Exp_T'Image (Exponent);
            begin
               if Exponent >= 0 then E_Img (1) := '+'; end if;
               Put_Character.all (E_Img (1));
               for I in E_Img'Length + 1 .. Exp loop
                  Put_Character.all ('0');
               end loop;
               for I in 2 .. E_Img'Last loop
                  Put_Character.all (E_Img (I));
               end loop;
            end;
            Free (Buffer);
         exception
            when others =>
               Free (Buffer);
               raise;
         end;
      else
         declare
            --  Say d = # decimal digits and b = # binary digits
            --  10^{d-1} \leqslant Arg < 10^d
            --  \ln Arg < d\ln 10 \leqslant \ln Arg + \ln 10
            --  \ln Arg < b\ln 2  \leqslant \ln Arg + \ln 2
            --  d \leqslant \frac{\ln Arg}{\ln 10} + 1
            --            < b\frac{\ln 2}{\ln 10} + 1 < b / 3 + 1
            N_Digits : constant unsigned_long
              := unsigned_long'Max (1, Mpf_Get_Prec (Item) / 3);
            --  We want to be sure to ask at least one digit, no C
            --  allocated-string.
            Buffer : Char_Array_Access
              := new char_array (1 .. size_t (N_Digits) + 2); --  sign nul
         begin
            Mpf_Get_Str (Buffer.all, Exponent, 10, Buffer'Length - 2, Item);
            if Exponent > 0 then
               Blank_And_Sign (Buffer.all, Natural (Exponent));
               for I in 1 .. Exponent loop Copy (Buffer.all); end loop;
               Put_Character.all ('.');
               for I in 1 .. Actual_Aft loop Copy (Buffer.all); end loop;
            else
               Exponent := -Exponent;
               Blank_And_Sign (Buffer.all, 1);
               Put_Character.all ('0');
               Put_Character.all ('.');
               if Mp_Exp_T (Actual_Aft) <= Exponent then
                  for I in 1 .. Actual_Aft loop
                     Put_Character.all ('0');
                  end loop;
               else
                  for I in 1 .. Exponent loop
                     Put_Character.all ('0');
                  end loop;
                  for I in Exponent + 1 .. Mp_Exp_T (Actual_Aft) loop
                     Copy (Buffer.all);
                  end loop;
               end if;
            end if;
            Free (Buffer);
         exception
            when others =>
               Free (Buffer);
               raise;
         end;
      end if;
   end Put;

   package body Generic_Scan is

      procedure Blanks_And_Sign (Buffer   : in out char_array;
                                 Next_Out : in out size_t);

      procedure Scan_Based_Numeral
        (Action : access procedure;     --  Consuming a digit
         Base   : in     int);
      procedure Copy (Buffer   : in out char_array;
                      Next_Out : in out size_t);
      procedure Copy_Numeral (Buffer    : in out char_array;
                              Next_Out  : in out size_t;
                              Dot_Seen  :    out Boolean;
                              Base      : in     int;
                              Allow_Dot : in     Boolean);
      procedure Copy_Literal (Buffer      : in out char_array;
                              Next_Out    : in out size_t;
                              Base        :    out int;
                              Allow_Float : in     Boolean);

      procedure Blanks_And_Sign (Buffer   : in out char_array;
                                 Next_Out : in out size_t)
      is
      begin
         while Is_Blank (Next) loop
            Consume;
         end loop;
         if Next = '+' then
            Consume;
         elsif Next = '-' then
            Copy (Buffer, Next_Out);
         end if;
      end Blanks_And_Sign;

      procedure Scan_Based_Numeral
        (Action : access procedure; --  Consuming a digit
         Base   : in int)
      is
         Digit_Is_Mandatory : Boolean := True;
      begin
         loop
            if Is_Digit (Next, Base) then
               Action.all;
               Digit_Is_Mandatory := False;
            elsif Digit_Is_Mandatory then
               raise Ada.IO_Exceptions.Data_Error;
            elsif Next = '_' then
               Digit_Is_Mandatory := True;
               Consume;
            else
               return;
            end if;
         end loop;
      end Scan_Based_Numeral;

      pragma Inline (Copy);
      procedure Copy (Buffer   : in out char_array;
                      Next_Out : in out size_t)
      is
      begin
         Buffer (Next_Out) := To_C (Next);
         Next_Out := Next_Out + 1;
         Consume;
      end Copy;

      procedure Copy_Numeral
        (Buffer    : in out char_array;
         Next_Out  : in out size_t;
         Dot_Seen  :    out Boolean;
         Base      : in     int;
         Allow_Dot : in     Boolean)
      is
         procedure Action;
         procedure Action is begin Copy (Buffer, Next_Out); end Action;
      begin
         Dot_Seen := False;
         if Allow_Dot and Next = '.' then
            Copy (Buffer, Next_Out);
            Dot_Seen := True;
         end if;
         Scan_Based_Numeral (Action'Access, Base);
         if Allow_Dot and not Dot_Seen and Next = '.' then
            Copy (Buffer, Next_Out);
            Dot_Seen := True;
            if Is_Digit (Next, Base) then
               Scan_Based_Numeral (Action'Access, Base);
            end if;
         end if;
      end Copy_Numeral;

      procedure Copy_Literal
        (Buffer      : in out char_array;
         Next_Out    : in out size_t;
         Base        :    out int;
         Allow_Float : in     Boolean)
      is
         Start    : constant size_t := Next_Out;
         Dot_Seen : Boolean;
      begin
         Copy_Numeral (Buffer, Next_Out, Dot_Seen, 10,
                       Allow_Dot => Allow_Float);
         if Next /= '#' or Dot_Seen then
            Base := 10;
         else
            Consume;
            Base := 0;
            for I in Start .. Next_Out - 1 loop
               Base := Base * 10
                 + char'Pos (Buffer (I)) - char'Pos (To_C ('0'));
               if Base > 16 then raise Ada.IO_Exceptions.Data_Error; end if;
               --  Check it before an overflow occurs.
            end loop;
            if Base < 2 then raise Ada.IO_Exceptions.Data_Error; end if;
            Next_Out := Start;
            Copy_Numeral (Buffer, Next_Out, Dot_Seen, Base,
                          Allow_Dot => Allow_Float);
            if Next /= '#' then
               raise Ada.IO_Exceptions.Data_Error;
            end if;
            Consume;
         end if;
      end Copy_Literal;

      procedure Get_Mpz_T (Item  : in out Mpz_T;
                           Width : in     Natural)
      is
         Buffer    : Char_Array_Access
           := new char_array (1 .. size_t (Width) + 1); --  Keep space for nul.
         Next_Out  : size_t := Buffer'First;
         Base, Ret : int;
         Exponent  : unsigned_long := 0;
         Temp      : Mpz_T;
         procedure Action;
         procedure Action is begin
            Exponent := Exponent * 10
              + Character'Pos (Next) - Character'Pos ('0');
            Consume;
         end Action;
      begin
         Blanks_And_Sign (Buffer.all, Next_Out);
         Copy_Literal (Buffer.all, Next_Out, Base, Allow_Float => False);
         Buffer.all (Next_Out) := nul;
         Mpz_Set_Str (Ret, Item, Buffer.all, Base);
         pragma Assert (Ret = 0);
         if Next = 'E' or Next = 'e' then
            Consume;
            if Next = '+' then Consume; end if;
            Scan_Based_Numeral (Action'Access, 10);
            Mpz_Init (Temp);
            Mpz_Ui_Pow_Ui (Temp, 10, Exponent);
            pragma Warnings
              (Off,
               "writable actual for ""Rop"" overlaps with actual for ""Op1""");
            Mpz_Mul (Item, Item, Temp);
            pragma Warnings
              (On,
               "writable actual for ""Rop"" overlaps with actual for ""Op1""");
            Mpz_Clear (Temp);
         end if;
         Free (Buffer);
      exception
         when others =>
            Free (Buffer);
            raise;
      end Get_Mpz_T;

      procedure Get_Mpf_T (Item  : in out Mpf_T;
                           Width : in     Natural)
      is
         Buffer    : Char_Array_Access
           := new char_array (1 .. size_t (Width) + 1); --  Keep space for nul.
         Next_Out  : size_t := Buffer'First;
         Base, Ret : int;
         Dot_Seen  : Boolean;
      begin
         Blanks_And_Sign (Buffer.all, Next_Out);
         Copy_Literal (Buffer.all, Next_Out, Base, Allow_Float => True);
         if Next = 'E' or Next = 'e' then
            Consume;
            Buffer.all (Next_Out) := To_C ('@');
            Next_Out := Next_Out + 1;
            if Next = '+' then
               Consume;
            elsif Next = '-' then
               Copy (Buffer.all, Next_Out);
            end if;
            Copy_Numeral (Buffer.all, Next_Out, Dot_Seen, 10,
                          Allow_Dot => False);
         end if;
         Buffer.all (Next_Out) := nul;
         Mpf_Set_Str (Ret, Item, Buffer.all, -Base);
         pragma Assert (Ret = 0);
         Free (Buffer);
      exception
         when others =>
            Free (Buffer);
            raise;
      end Get_Mpf_T;

   end Generic_Scan;

end GNU_Multiple_Precision.Aux;
