-- 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;