path: root/src/scanner-scan_literal.adb

--  Lexical analysis for numbers.
--  Copyright (C) 2002 - 2014 Tristan Gingold
--
--  GHDL 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 2, or (at your option) any later
--  version.
--
--  GHDL 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 GHDL; see the file COPYING.  If not, write to the Free
--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
--  02111-1307, USA.
with Ada.Unchecked_Conversion;

separate (Scanner)

-- scan a decimal literal or a based literal.
--
-- LRM93 13.4.1
-- DECIMAL_LITERAL ::= INTEGER [ . INTEGER ] [ EXPONENT ]
-- EXPONENT ::= E [ + ] INTEGER | E - INTEGER
--
-- LRM93 13.4.2
-- BASED_LITERAL ::= BASE # BASED_INTEGER [ . BASED_INTEGER ] # EXPONENT
-- BASE ::= INTEGER
procedure Scan_Literal is
   --  The base of an E_NUM is 2**16.
   --  Type Uint16 is the type of a digit.
   type Uint16 is mod 2 ** 16;

   type Uint32 is mod 2 ** 32;

   --  Type of the exponent.
   type Sint16 is range -2 ** 15 .. 2 ** 15 - 1;

   --  Number of digits in a E_NUM.
   --  We want at least 64bits of precision, so at least 5 digits of 16 bits
   --  are required.
   Nbr_Digits : constant Sint16 := 5;
   subtype Digit_Range is Sint16 range 0 .. Nbr_Digits - 1;

   type Uint16_Array is array (Sint16 range <>) of Uint16;

   --  The value of an E_NUM is (S(N-1)|S(N-2) .. |S(0))* 2**(16*E)
   --  where '|' is concatenation.
   type E_Num is record
      S : Uint16_Array (Digit_Range);
      E : Sint16;
   end record;

   E_Zero : constant E_Num := (S => (others => 0), E => 0);
   E_One  : constant E_Num := (S => (0 => 1, others => 0), E => 0);

   --  Compute RES = E * B + V.
   --  RES and E can be the same object.
   procedure Bmul (Res : out E_Num; E : E_Num; V : Uint16; B : Uint16);

   --  Convert to integer.
   procedure Fix (Res : out Iir_Int64; Ok : out Boolean; E : E_Num);

   --  RES := A * B
   --  RES can be A or B.
   procedure Mul (Res : out E_Num; A, B : E_Num);

   --  RES := A / B.
   --  RES can be A.
   --  May raise constraint error.
   procedure Div (Res : out E_Num; A, B: E_Num);

   --  Convert V to an E_Num.
   function To_E_Num (V : Uint16) return E_Num;

   --  Convert E to RES.
   procedure To_Float (Res : out Iir_Fp64; Ok : out Boolean; E : E_Num);

   procedure Bmul (Res : out E_Num; E : E_Num; V : Uint16; B : Uint16)
   is
      --  The carry.
      C : Uint32;
   begin
      --  Only consider V if E is not scaled (otherwise V is not significant).
      if E.E = 0 then
         C := Uint32 (V);
      else
         C := 0;
      end if;

      --  Multiply and propagate the carry.
      for I in Digit_Range loop
         C := Uint32 (E.S (I)) * Uint32 (B) + C;
         Res.S (I) := Uint16 (C mod Uint16'Modulus);
         C := C / Uint16'Modulus;
      end loop;

      --  There is a carry, shift.
      if C /= 0 then
         --  ERR: Possible overflow.
         Res.E := E.E + 1;
         for I in 0 .. Nbr_Digits - 2 loop
            Res.S (I) := Res.S (I + 1);
         end loop;
         Res.S (Nbr_Digits - 1) := Uint16 (C);
      else
         Res.E := E.E;
      end if;
   end Bmul;

   type Uint64 is mod 2 ** 64;
   function Shift_Left (Value : Uint64; Amount: Natural) return Uint64;
   function Shift_Left (Value : Uint16; Amount: Natural) return Uint16;
   pragma Import (Intrinsic, Shift_Left);

   function Shift_Right (Value : Uint16; Amount: Natural) return Uint16;
   pragma Import (Intrinsic, Shift_Right);

   function Unchecked_Conversion is new Ada.Unchecked_Conversion
     (Source => Uint64, Target => Iir_Int64);

   procedure Fix (Res : out Iir_Int64; Ok : out Boolean; E : E_Num)
   is
      R : Uint64;
      M : Sint16;
   begin
      --  Find the most significant digit.
      M := -1;
      for I in reverse Digit_Range loop
         if E.S (I) /= 0 then
            M := I;
            exit;
         end if;
      end loop;

      --  Handle the easy 0 case.
      --  The case M = -1 is handled below, in the normal flow.
      if M + E.E < 0 then
         Res := 0;
         Ok := True;
         return;
      end if;

      --  Handle overflow.
      --  4 is the number of uint16 in a uint64.
      if M + E.E >= 4 then
         Ok := False;
         return;
      end if;

      --  Convert
      R := 0;
      for I in 0 .. M loop
         R := R or Shift_Left (Uint64 (E.S (I)), 16 * Natural (E.E + I));
      end loop;
      --  Check the sign bit is 0.
      if (R and Shift_Left (1, 63)) /= 0 then
         Ok := False;
      else
         Ok := True;
         Res := Unchecked_Conversion (R);
      end if;
   end Fix;

   --  Return the position of the most non-null digit, -1 if V is 0.
   function First_Digit (V : E_Num) return Sint16 is
   begin
      for I in reverse Digit_Range loop
         if V.S (I) /= 0 then
            return I;
         end if;
      end loop;
      return -1;
   end First_Digit;

   procedure Mul (Res : out E_Num; A, B : E_Num)
   is
      T : Uint16_Array (0 .. 2 * Nbr_Digits - 1);
      V : Uint32;
      Max : Sint16;
   begin
      V := 0;
      for I in 0 .. Nbr_Digits - 1 loop
         for J in 0 .. I loop
            V := V + Uint32 (A.S (J)) * Uint32 (B.S (I - J));
         end loop;
         T (I) := Uint16 (V mod Uint16'Modulus);
         V := V / Uint16'Modulus;
      end loop;
      for I in Nbr_Digits .. 2 * Nbr_Digits - 2 loop
         for J in I - Nbr_Digits + 1 .. Nbr_Digits - 1 loop
            V := V + Uint32 (A.S (J)) * Uint32 (B.S (I - J));
         end loop;
         T (I) := Uint16 (V mod Uint16'Modulus);
         V := V / Uint16'Modulus;
      end loop;
      T (T'Last) := Uint16 (V);
      --  Search the leading non-nul.
      Max := -1;
      for I in reverse T'Range loop
         if T (I) /= 0 then
            Max := I;
            exit;
         end if;
      end loop;
      if Max > Nbr_Digits - 1 then
         --  Loss of precision.
         --  Round.
         if T (Max - Nbr_Digits) >= Uint16 (Uint16'Modulus / 2) then
            V := 1;
            for I in Max - (Nbr_Digits - 1) .. Max loop
               V := V + Uint32 (T (I));
               T (I) := Uint16 (V mod Uint16'Modulus);
               V := V / Uint16'Modulus;
               exit when V = 0;
            end loop;
            if V /= 0 then
               Max := Max + 1;
               T (Max) := Uint16 (V);
            end if;
         end if;
         Res.S := T (Max - (Nbr_Digits - 1) .. Max);
         --  This may overflow.
         Res.E := A.E + B.E + Max - (Nbr_Digits - 1);
      else
         Res.S (0 .. Max) := T (0 .. Max);
         Res.S (Max + 1 .. Nbr_Digits - 1) := (others => 0);
         --  This may overflow.
         Res.E := A.E + B.E;
      end if;
   end Mul;

   procedure Div (Res : out E_Num; A, B: E_Num)
   is
      Dividend : Uint16_Array (0 .. Nbr_Digits);
      A_F : constant Sint16 := First_Digit (A);
      B_F : constant Sint16 := First_Digit (B);

      --  Digit corresponding to the first digit of B.
      Doff : constant Sint16 := Dividend'Last - B_F;
      Q : Uint16;
      C, N_C : Uint16;
   begin
      --  Check for division by 0.
      if B_F < 0 then
         raise Constraint_Error;
      end if;

      --  Copy and shift dividend.
      --  Bit 15 of the most significant digit of A becomes bit 0 of the
      --  most significant digit of DIVIDEND.  Therefore we are sure
      --  DIVIDEND < B (after realignment).
      C := 0;
      for K in 0 .. A_F loop
         N_C := Shift_Right (A.S (K), 15);
         Dividend (Dividend'Last - A_F - 1 + K)
           := Shift_Left (A.S (K), 1) or C;
         C := N_C;
      end loop;
      Dividend (Nbr_Digits) := C;
      Dividend (0 .. Dividend'last - 2 - A_F) := (others => 0);

      --  Algorithm is the same as division by hand.
      C := 0;
      for I in reverse Digit_Range loop
         Q := 0;
         for J in 0 .. 15 loop
            declare
               Borrow : Uint32;
               Tmp : Uint16_Array (0 .. B_F);
               V : Uint32;
               V16 : Uint16;
            begin
               --  Compute TMP := dividend - B;
               Borrow := 0;
               for K in 0 .. B_F loop
                  V := Uint32 (B.S (K)) + Borrow;
                  V16 := Uint16 (V mod Uint16'Modulus);
                  if V16 > Dividend (Doff + K) then
                     Borrow := 1;
                  else
                     Borrow := 0;
                  end if;
                  Tmp (K) := Dividend (Doff + K) - V16;
               end loop;

               --  If the last shift creates a carry, we are sure Dividend > B
               if C /= 0 then
                  Borrow := 0;
               end if;

               Q := Q * 2;
               --  Begin of : Dividend = Dividend * 2
               C := 0;
               for K in 0 .. Doff - 1 loop
                  N_C := Shift_Right (Dividend (K), 15);
                  Dividend (K) := Shift_Left (Dividend (K), 1) or C;
                  C := N_C;
               end loop;

               if Borrow = 0 then
                  --  Dividend > B
                  Q := Q + 1;
                  --  Dividend = Tmp * 2
                  --           = (Dividend - B) * 2
                  for K in Doff .. Nbr_Digits loop
                     N_C := Shift_Right (Tmp (K - Doff), 15);
                     Dividend (K) := Shift_Left (Tmp (K - Doff), 1) or C;
                     C := N_C;
                  end loop;
               else
                  --  Dividend = Dividend * 2
                  for K in Doff .. Nbr_Digits loop
                     N_C := Shift_Right (Dividend (K), 15);
                     Dividend (K) := Shift_Left (Dividend (K), 1) or C;
                     C := N_C;
                  end loop;
               end if;
            end;
         end loop;
         Res.S (I) := Q;
      end loop;
      Res.E := A.E - B.E + (A_F - B_F) - (Nbr_Digits - 1);
   end Div;

   procedure To_Float (Res : out Iir_Fp64; Ok : out Boolean; E : E_Num)
   is
      V : Iir_Fp64;
      P : Iir_Fp64;
   begin
      Res := 0.0;
      P := Iir_Fp64'Scaling (1.0, 16 * E.E);
      for I in Digit_Range loop
         V := Iir_Fp64 (E.S (I)) * P;
         P := Iir_Fp64'Scaling (P, 16);
         Res := Res + V;
      end loop;
      Ok := True;
   end To_Float;

   function To_E_Num (V : Uint16) return E_Num
   is
      Res : E_Num;
   begin
      Res.E := 0;
      Res.S := (0 => V, others => 0);
      return Res;
   end To_E_Num;

   --  Numbers of digits.
   Scale : Integer;
   Res : E_Num;

   --  LRM 13.4.1
   --  INTEGER ::= DIGIT { [ UNDERLINE ] DIGIT }
   --
   --  Update SCALE, RES.
   --  The first character must be a digit.
   procedure Scan_Integer
   is
      C : Character;
   begin
      C := Source (Pos);
      loop
         --  C is a digit.
         Bmul (Res, Res, Character'Pos (C) - Character'Pos ('0'), 10);
         Scale := Scale + 1;

         Pos := Pos + 1;
         C := Source (Pos);
         if C = '_' then
            loop
               Pos := Pos + 1;
               C := Source (Pos);
               exit when C /= '_';
               Error_Msg_Scan ("double underscore in number");
            end loop;
            if C not in '0' .. '9' then
               Error_Msg_Scan ("underscore must be followed by a digit");
            end if;
         end if;
         exit when C not in '0' .. '9';
      end loop;
   end Scan_Integer;

   C : Character;
   D : Uint16;
   Ok : Boolean;
   Has_Dot : Boolean;
   Exp : Integer;
   Exp_Neg : Boolean;
   Base : Uint16;
begin
   --  Start with a simple and fast conversion.
   C := Source (Pos);
   D := 0;
   loop
      D := D * 10 + Character'Pos (C) - Character'Pos ('0');

      Pos := Pos + 1;
      C := Source (Pos);
      if C = '_' then
         loop
            Pos := Pos + 1;
            C := Source (Pos);
            exit when C /= '_';
            Error_Msg_Scan ("double underscore in number");
         end loop;
         if C not in '0' .. '9' then
            Error_Msg_Scan ("underscore must be followed by a digit");
         end if;
      end if;
      if C not in '0' .. '9' then
         if C = '.' or else C = '#' or else (C = 'e' or C = 'E' or C = ':')
         then
            --  Continue scanning.
            Res := To_E_Num (D);
            exit;
         end if;

         --  Finished.
         --  a universal integer.
         Current_Token := Tok_Integer;
         --  No possible overflow.
         Current_Context.Int64 := Iir_Int64 (D);
         return;
      elsif D >= 6552 then
         --  Number may be greather than the uint16 limit.
         Scale := 0;
         Res := To_E_Num (D);
         Scan_Integer;
         exit;
      end if;
   end loop;

   Has_Dot := False;
   Base := 10;

   C := Source (Pos);
   if C = '.' then
      --  Decimal integer.
      Has_Dot := True;
      Scale := 0;
      Pos := Pos + 1;
      C := Source (Pos);
      if C not in '0' .. '9' then
         Error_Msg_Scan ("a dot must be followed by a digit");
         return;
      end if;
      Scan_Integer;
   elsif C = '#'
     or else (C = ':' and then (Source (Pos + 1) in '0' .. '9'
                                or else Source (Pos + 1) in 'a' .. 'f'
                                or else Source (Pos + 1) in 'A' .. 'F'))
   then
      --  LRM 13.10
      --  The number sign (#) of a based literal can be replaced by colon (:),
      --  provided that the replacement is done for both occurrences.
      -- GHDL: correctly handle 'variable v : integer range 0 to 7:= 3'.
      --   Is there any other places where a digit can be followed
      --   by a colon ? (See IR 1093).

      --  Based integer.
      declare
         Number_Sign : constant Character := C;
         Res_Int : Iir_Int64;
      begin
         Fix (Res_Int, Ok, Res);
         if not Ok or else Res_Int > 16 then
            --  LRM 13.4.2
            --  The base must be [...] at most sixteen.
            Error_Msg_Scan ("base must be at most 16");
            --  Fallback.
            Base := 16;
         elsif Res_Int < 2 then
            --  LRM 13.4.2
            --  The base must be at least two [...].
            Error_Msg_Scan ("base must be at least 2");
            --  Fallback.
            Base := 2;
         else
            Base := Uint16 (Res_Int);
         end if;

         Pos := Pos + 1;
         Res := E_Zero;
         C := Source (Pos);
         loop
            if C >= '0' and C <= '9' then
               D := Character'Pos (C) - Character'Pos ('0');
            elsif C >= 'A' and C <= 'F' then
               D := Character'Pos (C) - Character'Pos ('A') + 10;
            elsif C >= 'a' and C <= 'f' then
               D := Character'Pos (C) - Character'Pos ('a') + 10;
            else
               Error_Msg_Scan ("bad extended digit");
               exit;
            end if;

            if D >= Base then
               --  LRM 13.4.2
               --  The conventional meaning of base notation is
               --  assumed; in particular the value of each extended
               --  digit of a based literal must be less then the base.
               Error_Msg_Scan ("digit beyond base");
               D := 1;
            end if;
            Pos := Pos + 1;
            Bmul (Res, Res, D, Base);
            Scale := Scale + 1;

            C := Source (Pos);
            if C = '_' then
               loop
                  Pos := Pos + 1;
                  C := Source (Pos);
                  exit when C /= '_';
                  Error_Msg_Scan ("double underscore in based integer");
               end loop;
            elsif C = '.' then
               if Has_Dot then
                  Error_Msg_Scan ("double dot ignored");
               else
                  Has_Dot := True;
                  Scale := 0;
               end if;
               Pos := Pos + 1;
               C := Source (Pos);
            elsif C = Number_Sign then
               Pos := Pos + 1;
               exit;
            elsif C = '#' or C = ':' then
               Error_Msg_Scan ("bad number sign replacement character");
               exit;
            end if;
         end loop;
      end;
   end if;
   C := Source (Pos);
   Exp := 0;
   if C = 'E' or else C = 'e' then
      Pos := Pos + 1;
      C := Source (Pos);
      Exp_Neg := False;
      if C = '+' then
         Pos := Pos + 1;
         C := Source (Pos);
      elsif C = '-' then
         if Has_Dot then
            Exp_Neg := True;
         else
            --  LRM 13.4.1
            --  An exponent for an integer literal must not have a minus sign.
            --
            --  LRM 13.4.2
            --  An exponent for a based integer literal must not have a minus
            --  sign.
            Error_Msg_Scan
              ("negative exponent not allowed for integer literal");
         end if;
         Pos := Pos + 1;
         C := Source (Pos);
      end if;
      if C not in '0' .. '9' then
         Error_Msg_Scan ("digit expected after exponent");
      else
         loop
            --  C is a digit.
            Exp := Exp * 10 + (Character'Pos (C) - Character'Pos ('0'));

            Pos := Pos + 1;
            C := Source (Pos);
            if C = '_' then
               loop
                  Pos := Pos + 1;
                  C := Source (Pos);
                  exit when C /= '_';
                  Error_Msg_Scan ("double underscore not allowed in integer");
               end loop;
               if C not in '0' .. '9' then
                  Error_Msg_Scan ("digit expected after underscore");
                  exit;
               end if;
            elsif C not in '0' .. '9' then
               exit;
            end if;
         end loop;
      end if;
      if Exp_Neg then
         Exp := -Exp;
      end if;
   end if;

   if Has_Dot then
      Scale := Scale - Exp;
   else
      Scale := -Exp;
   end if;
   if Scale /= 0 then
      declare
         Scale_Neg : Boolean;
         Val_Exp : E_Num;
         Val_Pow : E_Num;
      begin
         if Scale > 0 then
            Scale_Neg := True;
         else
            Scale_Neg := False;
            Scale := -Scale;
         end if;

         Val_Pow := To_E_Num (Base);
         Val_Exp := E_One;
         while Scale /= 0 loop
            if Scale mod 2 = 1 then
               Mul (Val_Exp, Val_Exp, Val_Pow);
            end if;
            Scale := Scale / 2;
            Mul (Val_Pow, Val_Pow, Val_Pow);
         end loop;
         if Scale_Neg then
            Div (Res, Res, Val_Exp);
         else
            Mul (Res, Res, Val_Exp);
         end if;
      end;
   end if;

   if Has_Dot then
      -- a universal real.
      Current_Token := Tok_Real;
      -- Set to a valid literal, in case of constraint error.
      To_Float (Current_Context.Fp64, Ok, Res);
      if not Ok then
         Error_Msg_Scan ("literal beyond real bounds");
      end if;
   else
      -- a universal integer.
      Current_Token := Tok_Integer;
      -- Set to a valid literal, in case of constraint error.
      Fix (Current_Context.Int64, Ok, Res);
      if not Ok then
         Error_Msg_Scan ("literal beyond integer bounds");
      end if;
   end if;
exception
   when Constraint_Error =>
      Error_Msg_Scan ("literal overflow");
end Scan_Literal;