summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--canon.adb4
-rw-r--r--evaluation.adb138
-rw-r--r--translate/grt/grt-disp_rti.adb4
-rw-r--r--translate/grt/grt-values.adb331
4 files changed, 435 insertions, 42 deletions
diff --git a/canon.adb b/canon.adb
index 317261b..6a24b26 100644
--- a/canon.adb
+++ b/canon.adb
@@ -241,7 +241,9 @@ package body Canon is
--Canon_Extract_Sensitivity
-- (Get_Prefix (Expr), Sensitivity_List, Is_Target);
- when Iir_Kinds_Scalar_Type_Attribute =>
+ when Iir_Kind_Value_Attribute
+ | Iir_Kind_Image_Attribute
+ | Iir_Kinds_Scalar_Type_Attribute =>
Canon_Extract_Sensitivity
(Get_Parameter (Expr), Sensitivity_List, Is_Target);
diff --git a/evaluation.adb b/evaluation.adb
index 07cc313..3bd18ce 100644
--- a/evaluation.adb
+++ b/evaluation.adb
@@ -22,6 +22,7 @@ with Iirs_Utils; use Iirs_Utils;
with Std_Package; use Std_Package;
with Flags; use Flags;
with Std_Names;
+with Ada.Characters.Handling;
package body Evaluation is
function Get_Physical_Value (Expr : Iir) return Iir_Int64
@@ -1346,6 +1347,104 @@ package body Evaluation is
return Res;
end Eval_Floating_Image;
+ function Eval_Enumeration_Image (Enum, Expr : Iir) return Iir
+ is
+ Name : constant String := Image_Identifier (Enum);
+ Image_Id : constant String_Id := Str_Table.Start;
+ begin
+ for i in Name'range loop
+ Str_Table.Append(Name(i));
+ end loop;
+ Str_Table.Finish;
+ return Build_String (Image_Id, Nat32(Name'Length), Expr);
+ end Eval_Enumeration_Image;
+
+ function Build_Enumeration_Value (Val : String; Enum, Expr : Iir) return Iir
+ is
+ Value : String(Val'range);
+ List : constant Iir_List := Get_Enumeration_Literal_List(Enum);
+ begin
+ for i in Val'range loop
+ Value(i) := Ada.Characters.Handling.To_Lower (Val(i));
+ end loop;
+ for i in 0 .. Get_Nbr_Elements(List) - 1 loop
+ if Value = Image_Identifier(Get_Nth_Element(List, i)) then
+ return Build_Discrete(Iir_Int64(i), Expr);
+ end if;
+ end loop;
+ Error_Msg_Sem ("value """ & Value & """ not in enumeration", Expr);
+ return Null_Iir;
+ end Build_Enumeration_Value;
+
+ function Eval_Physical_Image (Phys, Expr : Iir) return Iir
+ -- reduces to the base unit (e.g. femtoseconds)
+ is
+ Value : constant String := Iir_Int64'image(
+ Get_Physical_Literal_Value(Phys));
+ Unit : constant Iir := Get_Primary_Unit (Get_Base_Type (Get_Type(Phys)));
+ UnitName : constant String := Image_Identifier (Unit);
+ Image_Id : constant String_Id := Str_Table.Start;
+ Length : Nat32 := Value'Length + UnitName'Length + 1;
+ begin
+ for i in Value'range loop
+ -- Suppress the Ada +ve integer'image leading space
+ if i > Value'first or else Value(i) /= ' ' then
+ Str_Table.Append(Value(i));
+ else
+ Length := Length - 1;
+ end if;
+ end loop;
+ Str_Table.Append(' ');
+ for i in UnitName'range loop
+ Str_Table.Append(UnitName(i));
+ end loop;
+ Str_Table.Finish;
+
+ return Build_String (Image_Id, Length, Expr);
+ end Eval_Physical_Image;
+
+ function Build_Physical_Value (Val: String; Phys_Type, Expr: Iir) return Iir
+ is
+ function White (C : in Character) return Boolean is
+ NBSP : constant Character := Character'Val (160);
+ HT : constant Character := Character'Val (9);
+ begin
+ return C = ' ' or C = NBSP or C = HT;
+ end White;
+
+ UnitName : String(Val'range);
+ Sep : Natural;
+ Found_Unit : Boolean := false;
+ Unit : Iir := Get_Primary_Unit (Phys_Type);
+ begin
+ -- Separate string into numeric value and make lowercase unit.
+ for i in reverse Val'range loop
+ UnitName(i) := Ada.Characters.Handling.To_Lower (Val(i));
+ if White(Val(i)) and Found_Unit then
+ Sep := i;
+ exit;
+ else
+ Found_Unit := true;
+ end if;
+ end loop;
+ -- Unit name is UnitName(Sep+1..Unit'Last)
+
+ -- Chain down the units looking for matching one
+ Unit := Get_Primary_Unit (Phys_Type);
+ while Unit /= Null_Iir loop
+ exit when UnitName(Sep+1..UnitName'Last) = Image_Identifier(Unit);
+ Unit := Get_Chain (Unit);
+ end loop;
+ if Unit = Null_Iir then
+ Error_Msg_Sem ("Unit """ & UnitName(Sep+1..UnitName'Last)
+ & """ not in physical type", Expr);
+ return Null_Iir;
+ end if;
+ -- FIXME: Should we support real values too?
+ return Build_Physical(Iir_Int64'value(Val(Val'first .. Sep)), Expr);
+ end Build_Physical_Value;
+
+
function Eval_Incdec (Expr : Iir; N : Iir_Int64) return Iir
is
P : Iir_Int64;
@@ -1625,10 +1724,47 @@ package body Evaluation is
return Eval_Integer_Image (Get_Value (Param), Expr);
when Iir_Kind_Floating_Type_Definition =>
return Eval_Floating_Image (Get_Fp_Value (Param), Expr);
+ when Iir_Kind_Enumeration_Type_Definition =>
+ return Eval_Enumeration_Image (Param, Expr);
+ when Iir_Kind_Physical_Type_Definition =>
+ return Eval_Physical_Image (Param, Expr);
when others =>
- Error_Kind ("eval_static_expr('image)", Param_Type);
+ Error_Kind ("eval_static_expr('image)", Param);
end case;
end;
+ when Iir_Kind_Value_Attribute =>
+ declare
+ Param : Iir;
+ Param_Type : Iir;
+ begin
+ Param := Get_Parameter (Expr);
+ Param := Eval_Static_Expr (Param);
+ Set_Parameter (Expr, Param);
+ if Get_Kind (Param) /= Iir_Kind_String_Literal then
+ Error_Msg_Sem ("'value argument not a string", Expr);
+ return Null_Iir; -- or Expr?
+ else
+ -- what type are we converting the string to?
+ Param_Type := Get_Base_Type (Get_Type (Expr));
+ declare
+ Value : constant String := Image_String_Lit(Param);
+ begin
+ case Get_Kind (Param_Type) is
+ when Iir_Kind_Integer_Type_Definition =>
+ return Build_Discrete(Iir_Int64'value(Value), Expr);
+ when Iir_Kind_Enumeration_Type_Definition =>
+ return Build_Enumeration_Value (Value, Param_Type,
+ Expr);
+ when Iir_Kind_Floating_Type_Definition =>
+ return Build_Floating (Iir_Fp64'value (Value), Expr);
+ when Iir_Kind_Physical_Type_Definition =>
+ return Build_Physical_Value (Value, Param_Type, Expr);
+ when others =>
+ Error_Kind ("eval_static_expr('value)", Param);
+ end case;
+ end;
+ end if;
+ end;
when Iir_Kind_Left_Type_Attribute =>
return Build_Constant
diff --git a/translate/grt/grt-disp_rti.adb b/translate/grt/grt-disp_rti.adb
index c926775..d6f891a 100644
--- a/translate/grt/grt-disp_rti.adb
+++ b/translate/grt/grt-disp_rti.adb
@@ -253,8 +253,10 @@ package body Grt.Disp_Rti is
Disp_Record_Value
(Stream, To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Obj, Is_Sig);
when others =>
- Put (Stream, "??");
+ Put (Stream, "Unknown Rti Kind : ");
+ Disp_Kind(Rti.Kind);
end case;
+ Put_Line(":");
end Disp_Value;
procedure Disp_Kind (Kind : Ghdl_Rtik) is
diff --git a/translate/grt/grt-values.adb b/translate/grt/grt-values.adb
index c60c667..173c8ce 100644
--- a/translate/grt/grt-values.adb
+++ b/translate/grt/grt-values.adb
@@ -16,12 +16,19 @@
-- 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;
@@ -30,24 +37,15 @@ package body Grt.Values is
Chars := False;
-- GHDL: allow several leading whitespace.
while Pos < Len loop
- case S (Pos) is
- when ' '
- | NBSP
- | HT =>
- Pos := Pos + 1;
- when others =>
- Chars := True;
- exit;
- end case;
+ if White (S (Pos)) then
+ Pos := Pos + 1;
+ else
+ Chars := True;
+ exit;
+ end if;
end loop;
end Remove_Whitespace;
- procedure Stub_Error(S : String) is
- begin
- Error_E ("'value: function Ghdl_Value_" & S & " is a stub!"
- & "Please report as missing to http://gna.org/projects/ghdl");
- end Stub_Error;
-
function LC(C : in Character) return Character is
begin
if C >= 'A' and then C <= 'Z' then
@@ -60,12 +58,10 @@ package body Grt.Values is
procedure Make_LC_String(S : Std_String_Basep;
Pos : in out Ghdl_Index_Type;
- Len : Ghdl_Index_Type;
Str : out String) is
- pragma unreferenced(Len);
begin
for i in Str'range loop
- Str(i) := LC(S(Pos)); -- LC it later
+ Str(i) := LC(S(Pos));
Pos := Pos + 1;
end loop;
end Make_LC_String;
@@ -108,7 +104,7 @@ package body Grt.Values is
Str : String(1..Natural(Len - Pos));
Found : Boolean := False;
begin
- Make_LC_String(S, Pos, Len, Str);
+ 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;
@@ -126,7 +122,6 @@ package body Grt.Values is
if Chars then
Error_E ("'value: trailing characters after blank");
end if;
- -- Stub_Error("E8");
return Val;
end Ghdl_Value_Enum;
@@ -151,14 +146,14 @@ package body Grt.Values is
return Ghdl_E32'Val(Ghdl_Value_Enum (Str , Rti ));
end Ghdl_Value_E32;
- function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32
+ 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_I32;
+ Val, D, Base : Ghdl_I64;
Exp : Integer;
Chars : Ghdl_B2;
begin
@@ -320,40 +315,298 @@ package body Grt.Values is
-- GHDL: allow several trailing whitespace.
Remove_Whitespace(S, Pos, Len, Chars);
if Chars then
- Error_E ("'value: trailing characters after blank");
+ 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_F64 (Str : Std_String_Ptr) return Ghdl_F64 is
- pragma unreferenced(Str);
- Val : constant Ghdl_F64 := 0.0;
+ 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;
+
+ Base_Val : Ghdl_I64;
+ Multiple : Ghdl_Rti_Unit_Val;
+
+ Phys_Rti : Ghdl_Rtin_Type_Physical_Acc;
+ Unit : Ghdl_Rtin_Unit_Acc;
+ Start, Finish : Ghdl_Index_Type;
+
begin
- Stub_Error("F64");
- return Val;
- end Ghdl_Value_F64;
+ Phys_Rti := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+
+ S.Bounds := To_Std_String_Boundp(Bound'Address);
+ -- find characters at the end...
+ Finish := Ghdl_Index_Type(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;
+ -- and capture integer value
+ -- FIXME: Should we support real values too?
+ Base_Val := Ghdl_Value_I64(To_Std_String_Ptr(S'Address));
+
+ 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
+ return Base_Val * Ghdl_I64(Multiple.Unit_64);
+ else
+ return Base_Val * Ghdl_I64(Multiple.Unit_32);
+ end if;
+ end Ghdl_Value_Physical_Type;
function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
return Ghdl_I64
is
- pragma unreferenced(Str);
- pragma unreferenced(Rti);
- Val : constant Ghdl_I64 := 0;
begin
- Stub_Error("P64");
- return Val;
+ 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
- pragma unreferenced(Str);
- pragma unreferenced(Rti);
- Val : constant Ghdl_I32 := 0;
begin
- Stub_Error("P32");
- return Val;
+ 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;
generated by cgit (git 2.34.1) at 2024-12-22 11:03:10 +0000