-- GHDL Run Time (GRT) - 'value subprograms.
-- Copyright (C) 2002, 2003, 2004, 2005 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 GCC; see the file COPYING. If not, write to the Free
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
with Grt.Errors; use Grt.Errors;
with System;
with Ada.Unchecked_Conversion;
package body Grt.Values is
NBSP : constant Character := Character'Val (160);
HT : constant Character := Character'Val (9);
function White (C : in Character) return Boolean is
begin
return C = ' ' or C = NBSP or C = HT;
end White;
procedure Remove_Whitespace(S : in Std_String_Basep;
Pos : in out Ghdl_Index_Type;
Len : in Ghdl_Index_Type;
Chars : out Ghdl_B2) is
begin
Chars := False;
-- GHDL: allow several leading whitespace.
while Pos < Len loop
if White (S (Pos)) then
Pos := Pos + 1;
else
Chars := True;
exit;
end if;
end loop;
end Remove_Whitespace;
function LC(C : in Character) return Character is
begin
if C >= 'A' and then C <= 'Z' then
return Character'val(Character'pos(C) + Character'pos('a')
- Character'pos('A'));
else
return C;
end if;
end LC;
procedure Make_LC_String(S : Std_String_Basep;
Pos : in out Ghdl_Index_Type;
Str : out String) is
begin
for i in Str'range loop
Str(i) := LC(S(Pos));
Pos := Pos + 1;
end loop;
end Make_LC_String;
function StringMatch(Str : String; EnumStr : Ghdl_C_String) return boolean
is
EnumLen : constant Natural := strlen(EnumStr);
begin
for j in Str'range loop
if j > EnumLen or else Str(j) /= EnumStr(j) then
return false;
end if;
end loop;
if Str'last = EnumLen then
return true;
else
return false;
end if;
end StringMatch;
function Ghdl_Value_Enum (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
return Ghdl_Index_Type
is
Val : Ghdl_Index_Type := 0;
S : constant Std_String_Basep := Str.Base;
Len : constant Ghdl_Index_Type := Str.Bounds.Dim_1.Length;
Pos : Ghdl_Index_Type := 0;
Chars : Ghdl_B2;
Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
begin
Remove_Whitespace(S, Pos, Len, Chars);
if Pos = Len then
Error_E ("'value: empty string");
end if;
Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
declare
Str : String(1..Natural(Len - Pos));
Found : Boolean := False;
begin
Make_LC_String(S, Pos, Str);
for i in 0 .. Enum_Rti.Nbr - 1 loop
if StringMatch(Str, Enum_Rti.Names.all(i)) then
Found := True;
Val := i;
exit;
end if;
end loop;
if not Found then
Error_E ("'value: " & Str & " not in enumeration " &
Enum_Rti.Name.all(1..strlen(Enum_Rti.Name)));
end if;
end;
Remove_Whitespace(S, Pos, Len, Chars);
if Chars then
Error_E ("'value: trailing characters after blank");
end if;
return Val;
end Ghdl_Value_Enum;
function Ghdl_Value_B2 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
return Ghdl_B2
is
begin
return Ghdl_B2'Val(Ghdl_Value_Enum (Str , Rti ));
end Ghdl_Value_B2;
function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
return Ghdl_E8
is
begin
return Ghdl_E8'Val(Ghdl_Value_Enum (Str , Rti ));
end Ghdl_Value_E8;
function Ghdl_Value_E32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
return Ghdl_E32
is
begin
return Ghdl_E32'Val(Ghdl_Value_Enum (Str , Rti ));
end Ghdl_Value_E32;
function Ghdl_Value_I64 (Str : Std_String_Ptr) return Ghdl_I64
is
S : constant Std_String_Basep := Str.Base;
Len : constant Ghdl_Index_Type := Str.Bounds.Dim_1.Length;
Pos : Ghdl_Index_Type := 0;
C : Character;
Sep : Character;
Val, D, Base : Ghdl_I64;
Exp : Integer;
Chars : Ghdl_B2;
begin
-- LRM 14.1
-- Leading [and trailing] whitespace is allowed and ignored.
--
-- GHDL: allow several leading whitespace.
Remove_Whitespace(S, Pos, Len, Chars);
if Pos = Len then
Error_E ("'value: empty string");
end if;
C := S (Pos);
-- Be user friendly.
if C = '-' or C = '+' then
Error_E ("'value: leading sign +/- not allowed");
end if;
Val := 0;
loop
if C in '0' .. '9' then
Val := Val * 10 + Character'Pos (C) - Character'Pos ('0');
Pos := Pos + 1;
exit when Pos >= Len;
C := S (Pos);
else
Error_E ("'value: decimal digit expected");
end if;
case C is
when '_' =>
Pos := Pos + 1;
if Pos >= Len then
Error_E ("'value: trailing underscore");
end if;
C := S (Pos);
when '#'
| ':'
| 'E'
| 'e' =>
exit;
when ' '
| NBSP
| HT =>
Pos := Pos + 1;
exit;
when others =>
null;
end case;
end loop;
if Pos >= Len then
return Val;
end if;
if C = '#' or C = ':' then
Base := Val;
Val := 0;
Sep := C;
Pos := Pos + 1;
if Base < 2 or Base > 16 then
Error_E ("'value: bad base");
end if;
if Pos >= Len then
Error_E ("'value: missing based integer");
end if;
C := S (Pos);
loop
case C is
when '0' .. '9' =>
D := Character'Pos (C) - Character'Pos ('0');
when 'a' .. 'f' =>
D := Character'Pos (C) - Character'Pos ('a') + 10;
when 'A' .. 'F' =>
D := Character'Pos (C) - Character'Pos ('A') + 10;
when others =>
Error_E ("'value: digit expected");
end case;
if D >= Base then
Error_E ("'value: digit >= base");
end if;
Val := Val * Base + D;
Pos := Pos + 1;
if Pos >= Len then
Error_E ("'value: missing end sign number");
end if;
C := S (Pos);
if C = '#' or C = ':' then
if C /= Sep then
Error_E ("'value: sign number mismatch");
end if;
Pos := Pos + 1;
exit;
elsif C = '_' then
Pos := Pos + 1;
if Pos >= Len then
Error_E ("'value: no character after underscore");
end if;
C := S (Pos);
end if;
end loop;
else
Base := 10;
end if;
-- Handle exponent.
if C = 'e' or C = 'E' then
Pos := Pos + 1;
if Pos >= Len then
Error_E ("'value: no character after exponent");
end if;
C := S (Pos);
if C = '+' then
Pos := Pos + 1;
if Pos >= Len then
Error_E ("'value: no character after sign");
end if;
C := S (Pos);
elsif C = '-' then
Error_E ("'value: negativ exponent not allowed");
end if;
Exp := 0;
loop
if C in '0' .. '9' then
Exp := Exp * 10 + Character'Pos (C) - Character'Pos ('0');
Pos := Pos + 1;
exit when Pos >= Len;
C := S (Pos);
else
Error_E ("'value: decimal digit expected");
end if;
case C is
when '_' =>
Pos := Pos + 1;
if Pos >= Len then
Error_E ("'value: trailing underscore");
end if;
C := S (Pos);
when ' '
| NBSP
| HT =>
Pos := Pos + 1;
exit;
when others =>
null;
end case;
end loop;
while Exp > 0 loop
if Exp mod 2 = 1 then
Val := Val * Base;
end if;
Exp := Exp / 2;
Base := Base * Base;
end loop;
end if;
-- LRM 14.1
-- [Leading] and trailing whitespace is allowed and ignored.
--
-- GHDL: allow several trailing whitespace.
Remove_Whitespace(S, Pos, Len, Chars);
if Chars then
Error_E ("integer'value: trailing characters after blank");
end if;
return Val;
end Ghdl_Value_I64;
function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32
is
begin
return Ghdl_I32 (Ghdl_Value_I64 (Str));
end Ghdl_Value_I32;
function Ghdl_Value_Physical_Type (Str : Std_String_Ptr;
Rti : Ghdl_Rti_Access)
return Ghdl_I64
is
function To_Std_String_Ptr is new Ada.Unchecked_Conversion
(Source => System.Address, Target => Std_String_Ptr);
function To_Std_String_Boundp is new Ada.Unchecked_Conversion
(Source => System.Address, Target => Std_String_Boundp);
S : aliased Std_String := Str.all;
Bound : aliased Std_String_Bound := Str.Bounds.all;
Start, Finish : Ghdl_Index_Type;
Found_Real : Boolean := false;
Phys_Rti : Ghdl_Rtin_Type_Physical_Acc;
Unit : Ghdl_Rtin_Unit_Acc;
Multiple : Ghdl_Rti_Unit_Val;
Mult : Ghdl_I64;
begin
Phys_Rti := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
S.Bounds := To_Std_String_Boundp(Bound'Address);
-- find characters at the end...
Finish := Bound.Dim_1.Length - 1;
while White(S.Base.all(Finish)) loop
Finish := Finish - 1;
end loop;
Start := Finish;
while not White(S.Base.all(Start - 1)) loop
Start := Start - 1;
end loop;
-- shorten Bounds to exclude non-numeric part
Bound.Dim_1.Right := Bound.Dim_1.Right
- Std_Integer(Bound.Dim_1.Length - Start);
Bound.Dim_1.Length := Start;
-- does the string represent a Real?
for i in 0 .. Start loop
if S.Base.all(i) = '.' then
Found_Real := true;
end if;
end loop;
declare
Unit_Str : String(1 .. Natural(1 + Finish - Start));
Found : Boolean := False;
begin
Make_LC_String(Str.Base, Start, Unit_Str);
for i in 0 .. Phys_Rti.Nbr - 1 loop
Unit := To_Ghdl_Rtin_Unit_Acc(Phys_Rti.Units(i));
if StringMatch(Unit_Str, Unit.Name) then
Found := True;
Multiple := To_Ghdl_Rtin_Unit_Acc (Phys_Rti.Units (i)).Value;
exit;
end if;
end loop;
if not Found then
Error_E ("'value: Unit " & Unit_Str & " not in physical type" &
Phys_Rti.Name.all(1..strlen(Phys_Rti.Name)));
end if;
end;
if Rti.Kind = Ghdl_Rtik_Type_P64 then
Mult := Multiple.Unit_64;
else
Mult := Ghdl_I64(Multiple.Unit_32);
end if;
if Found_Real then
return Ghdl_I64 (Ghdl_Value_F64 (To_Std_String_Ptr(S'Address))
* Ghdl_F64 (Mult));
else
return Ghdl_Value_I64 (To_Std_String_Ptr(S'Address)) * Mult;
end if;
end Ghdl_Value_Physical_Type;
function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
return Ghdl_I64
is
begin
if Rti.Kind /= Ghdl_Rtik_Type_P64 then
Error_E ("Physical_Type_64'value: incorrect RTI");
end if;
return Ghdl_Value_Physical_Type(Str, Rti);
end Ghdl_Value_P64;
function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
return Ghdl_I32
is
begin
if Rti.Kind /= Ghdl_Rtik_Type_P32 then
Error_E ("Physical_Type_32'value: incorrect RTI");
end if;
return Ghdl_I32(Ghdl_Value_Physical_Type(Str, Rti));
end Ghdl_Value_P32;
-- From patch attached to https://gna.org/bugs/index.php?18352
-- thanks to Christophe Curis https://gna.org/users/lobotomy
function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64
is
S : constant Std_String_Basep := Str.Base;
Len : constant Ghdl_Index_Type := Str.Bounds.Dim_1.Length;
Pos : Ghdl_Index_Type := 0;
C : Character;
Chars : Ghdl_B2;
Is_Negative, Is_Neg_Exp : Boolean := False;
Base : Ghdl_F64;
Intg : Ghdl_I32;
Val, Df : Ghdl_F64;
Sep : Character;
FrcExp : Ghdl_F64;
begin
-- LRM 14.1
-- Leading [and trailing] whitespace is allowed and ignored.
--
-- GHDL: allow several leading whitespace.
Remove_Whitespace(S, Pos, Len, Chars);
if Pos = Len then
Error_E ("'value: empty string");
end if;
C := S (Pos);
if C = '-' then
Is_Negative := True;
Pos := Pos + 1;
elsif C = '+' then
Pos := Pos + 1;
end if;
if Pos >= Len then
Error_E ("'value: decimal digit expected");
end if;
-- Read Integer-or-Base part (may be optional)
Intg := 0;
while Pos < Len loop
C := S (Pos);
if C in '0' .. '9' then
Intg := Intg * 10 + Character'Pos (C) - Character'Pos ('0');
elsif C /= '_' then
exit;
end if;
Pos := Pos + 1;
end loop;
if Pos = Len then
return Ghdl_F64 (Intg);
end if;
-- Special case: base was specified
if C = '#' or C = ':' then
if Intg < 2 or Intg > 16 then
Error_E ("'value: bad base");
end if;
Base := Ghdl_F64 (Intg);
Val := 0.0;
Sep := C;
Pos := Pos + 1;
if Pos >= Len then
Error_E ("'value: missing based decimal");
end if;
-- Get the Integer part of the Value
while Pos < Len loop
C := S (Pos);
case C is
when '0' .. '9' =>
Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('0') );
when 'A' .. 'F' =>
Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('A') + 10);
when 'a' .. 'f' =>
Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('a') + 10);
when others =>
exit;
end case;
if C /= '_' then
if Df >= Base then
Error_E ("'value: digit greater than base");
end if;
Val := Val * Base + Df;
end if;
Pos := Pos + 1;
end loop;
if Pos >= Len then
Error_E ("'value: missing end sign number");
end if;
else
Base := 10.0;
Sep := ' ';
Val := Ghdl_F64 (Intg);
end if;
-- Handle the Fractional part
if C = '.' then
Pos := Pos + 1;
FrcExp := 1.0;
while Pos < Len loop
C := S (Pos);
case C is
when '0' .. '9' =>
Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('0'));
when 'A' .. 'F' =>
exit when Sep = ' ';
Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('A') + 10);
when 'a' .. 'f' =>
exit when Sep = ' ';
Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('a') + 10);
when others =>
exit;
end case;
if C /= '_' then
FrcExp := FrcExp / Base;
if Df > Base then
Error_E ("'value: digit greater than base");
end if;
Val := Val + Df * FrcExp;
end if;
Pos := Pos + 1;
end loop;
end if;
-- If base was specified, we must find here the end marker
if Sep /= ' ' then
if Pos >= Len then
Error_E ("'value: missing end sign number");
end if;
if C /= Sep then
Error_E ("'value: sign number mismatch");
end if;
Pos := Pos + 1;
end if;
-- Handle exponent
if Pos < Len then
C := S (Pos);
if C = 'e' or C = 'E' then
Pos := Pos + 1;
if Pos >= Len then
Error_E ("'value: no character after exponent");
end if;
C := S (Pos);
if C = '-' then
Is_Neg_Exp := True;
Pos := Pos + 1;
elsif C = '+' then
Pos := Pos + 1;
end if;
Intg := 0;
while Pos < Len loop
C := S (Pos);
if C in '0' .. '9' then
Intg := Intg * 10 + Character'Pos (C) - Character'Pos ('0');
else
exit;
end if;
Pos := Pos + 1;
end loop;
-- This Exponentiation method is sub-optimal,
-- but it does not depend on any library
FrcExp := 1.0;
if Is_Neg_Exp then
while Intg > 0 loop
FrcExp := FrcExp / 10.0;
Intg := Intg - 1;
end loop;
else
while Intg > 0 loop
FrcExp := FrcExp * 10.0;
Intg := Intg - 1;
end loop;
end if;
Val := Val * FrcExp;
end if;
end if;
-- LRM 14.1
-- [Leading] and trailing whitespace is allowed and ignored.
--
-- GHDL: allow several leading whitespace.
Remove_Whitespace(S, Pos, Len, Chars);
if Chars then
Error_E ("'value: trailing characters after blank");
end if;
if Is_Negative then
Val := -Val;
end if;
return Val;
end Ghdl_Value_F64;
end Grt.Values;