synth: rework value attribute

8 files changed, 254 insertions, 173 deletions

diff --git a/Makefile.in b/Makefile.in
index d722e94d2..57cffa19c 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -269,6 +269,7 @@ copy-sources.gcc: version.ads scripts/gcc/Make-lang.in
 	$(CP) -p $(srcdir)/src/grt/grt-table.ad? $(gcc_vhdl_dir)
 	$(CP) -p $(srcdir)/src/grt/grt-files_operations.ad? $(gcc_vhdl_dir)
 	$(CP) -p $(srcdir)/src/grt/grt-to_strings.ad? $(gcc_vhdl_dir)
+	$(CP) -p $(srcdir)/src/grt/grt-strings.ad? $(gcc_vhdl_dir)
 	$(CP) -p $(srcdir)/src/grt/grt-severity.ads $(gcc_vhdl_dir)
 	$(CP) -p $(srcdir)/src/grt/grt-readline_*.ad? $(gcc_vhdl_dir)
 	$(CP) -p $(srcdir)/src/ortho/*.ad? $(gcc_vhdl_dir)
diff --git a/src/grt/grt-to_strings.adb b/src/grt/grt-to_strings.adb
index 8b821ae0b..130388e3b 100644
--- a/src/grt/grt-to_strings.adb
+++ b/src/grt/grt-to_strings.adb
@@ -22,7 +22,9 @@
 --  covered by the GNU Public License.
 
 with Interfaces;
+
 with Grt.Fcvt;
+with Grt.Strings; use Grt.Strings;
 
 package body Grt.To_Strings is
    generic
@@ -509,4 +511,62 @@ package body Grt.To_Strings is
 
       return (Status => Value_Ok, Val => Val);
    end Value_F64;
+
+   --  Increase POS to skip leading whitespace characters, decrease LEN to
+   --  skip trailing whitespaces in string S.
+   procedure Remove_Whitespaces (S     : Std_String_Basep;
+                                 Len   : in out Ghdl_Index_Type;
+                                 Pos   : in out Ghdl_Index_Type) is
+   begin
+      --  GHDL: allow several leading whitespace.
+      while Pos < Len loop
+         exit when not Is_Whitespace (S (Pos));
+         Pos := Pos + 1;
+      end loop;
+
+      --  GHDL: allow several leading whitespace.
+      while Len > Pos loop
+         exit when not Is_Whitespace (S (Len - 1));
+         Len := Len - 1;
+      end loop;
+   end Remove_Whitespaces;
+
+   procedure Ghdl_Value_Physical_Split (Str : Std_String_Basep;
+                                        Len : Ghdl_Index_Type;
+                                        Is_Real : out Boolean;
+                                        Lit_Pos : out Ghdl_Index_Type;
+                                        Lit_End : out Ghdl_Index_Type;
+                                        Unit_Pos : out Ghdl_Index_Type)
+   is
+      L : Ghdl_Index_Type;
+   begin
+      --  LRM 14.1
+      --  Leading and trailing whitespace is allowed and ignored.
+      Lit_Pos := 0;
+      L := Len;
+      Remove_Whitespaces (Str, L, Lit_Pos);
+      pragma Unreferenced (Len);
+
+      --  Split between abstract literal (optionnal) and unit name.
+      Lit_End := Lit_Pos;
+      Is_Real := False;
+      while Lit_End < L loop
+         exit when Is_Whitespace (Str (Lit_End));
+         if Str (Lit_End) = '.' then
+            Is_Real := True;
+         end if;
+         Lit_End := Lit_End + 1;
+      end loop;
+      if Lit_End = L then
+         --  No literal
+         Unit_Pos := Lit_Pos;
+         Lit_End := 0;
+      else
+         Unit_Pos := Lit_End + 1;
+         while Unit_Pos < L loop
+            exit when not Is_Whitespace (Str (Unit_Pos));
+            Unit_Pos := Unit_Pos + 1;
+         end loop;
+      end if;
+   end Ghdl_Value_Physical_Split;
 end Grt.To_Strings;
diff --git a/src/grt/grt-to_strings.ads b/src/grt/grt-to_strings.ads
index 184bf8d78..a15a6aaee 100644
--- a/src/grt/grt-to_strings.ads
+++ b/src/grt/grt-to_strings.ads
@@ -106,4 +106,23 @@ package Grt.To_Strings is
    function Value_F64 (S : Std_String_Basep;
                        Len : Ghdl_Index_Type;
                        Init_Pos : Ghdl_Index_Type) return Value_F64_Result;
+
+   --  Increase POS to skip leading whitespace characters, decrease LEN to
+   --  skip trailing whitespaces in string S.
+   procedure Remove_Whitespaces (S     : Std_String_Basep;
+                                 Len   : in out Ghdl_Index_Type;
+                                 Pos   : in out Ghdl_Index_Type);
+
+   --  Extract position of numeric literal and unit in string STR.
+   --  Set IS_REAL if the unit is a real number (presence of '.').
+   --  Set UNIT_POS to the position of the first character of the unit name.
+   --  Set LIT_POS to the position of the first character of the numeric
+   --  literal (after whitespaces are skipped).
+   --  Set LIT_END to the position of the next character of the numeric lit.
+   procedure Ghdl_Value_Physical_Split (Str : Std_String_Basep;
+                                        Len : Ghdl_Index_Type;
+                                        Is_Real : out Boolean;
+                                        Lit_Pos : out Ghdl_Index_Type;
+                                        Lit_End : out Ghdl_Index_Type;
+                                        Unit_Pos : out Ghdl_Index_Type);
 end Grt.To_Strings;
diff --git a/src/grt/grt-values.adb b/src/grt/grt-values.adb
index b2e98f6a0..14f8f8075 100644
--- a/src/grt/grt-values.adb
+++ b/src/grt/grt-values.adb
@@ -26,23 +26,11 @@ with Grt.Strings; use Grt.Strings;
 with Grt.To_Strings; use Grt.To_Strings;
 
 package body Grt.Values is
-   --  Increase POS to skip leading whitespace characters, decrease LEN to
-   --  skip trailing whitespaces in string S.
    procedure Remove_Whitespaces (S     : Std_String_Basep;
                                  Len   : in out Ghdl_Index_Type;
                                  Pos   : in out Ghdl_Index_Type) is
    begin
-      --  GHDL: allow several leading whitespace.
-      while Pos < Len loop
-         exit when not Is_Whitespace (S (Pos));
-         Pos := Pos + 1;
-      end loop;
-
-      --  GHDL: allow several leading whitespace.
-      while Len > Pos loop
-         exit when not Is_Whitespace (S (Len - 1));
-         Len := Len - 1;
-      end loop;
+      Grt.To_Strings.Remove_Whitespaces (S, Len, Pos);
       if Pos = Len then
          Error_E ("'value: empty string");
       end if;
@@ -234,45 +222,6 @@ package body Grt.Values is
       return Value_F64 (S, Len, Pos);
    end Ghdl_Value_F64;
 
-   procedure Ghdl_Value_Physical_Split (Str : Std_String_Basep;
-                                        Len : Ghdl_Index_Type;
-                                        Is_Real : out Boolean;
-                                        Lit_Pos : out Ghdl_Index_Type;
-                                        Lit_End : out Ghdl_Index_Type;
-                                        Unit_Pos : out Ghdl_Index_Type)
-   is
-      L : Ghdl_Index_Type;
-   begin
-      --  LRM 14.1
-      --  Leading and trailing whitespace is allowed and ignored.
-      Lit_Pos := 0;
-      L := Len;
-      Remove_Whitespaces (Str, L, Lit_Pos);
-      pragma Unreferenced (Len);
-
-      --  Split between abstract literal (optionnal) and unit name.
-      Lit_End := Lit_Pos;
-      Is_Real := False;
-      while Lit_End < L loop
-         exit when Is_Whitespace (Str (Lit_End));
-         if Str (Lit_End) = '.' then
-            Is_Real := True;
-         end if;
-         Lit_End := Lit_End + 1;
-      end loop;
-      if Lit_End = L then
-         --  No literal
-         Unit_Pos := Lit_Pos;
-         Lit_End := 0;
-      else
-         Unit_Pos := Lit_End + 1;
-         while Unit_Pos < L loop
-            exit when not Is_Whitespace (Str (Unit_Pos));
-            Unit_Pos := Unit_Pos + 1;
-         end loop;
-      end if;
-   end Ghdl_Value_Physical_Split;
-
    function Ghdl_Value_Physical_Type (Str : Std_String_Ptr;
                                       Rti : Ghdl_Rti_Access)
                                      return Ghdl_I64
diff --git a/src/grt/grt-values.ads b/src/grt/grt-values.ads
index 8a81d1fbd..450295891 100644
--- a/src/grt/grt-values.ads
+++ b/src/grt/grt-values.ads
@@ -25,19 +25,6 @@ with Grt.Vhdl_Types; use Grt.Vhdl_Types;
 with Grt.Rtis; use Grt.Rtis;
 
 package Grt.Values is
-   --  Extract position of numeric literal and unit in string STR.
-   --  Set IS_REAL if the unit is a real number (presence of '.').
-   --  Set UNIT_POS to the position of the first character of the unit name.
-   --  Set LIT_POS to the position of the first character of the numeric
-   --  literal (after whitespaces are skipped).
-   --  Set LIT_END to the position of the next character of the numeric lit.
-   procedure Ghdl_Value_Physical_Split (Str : Std_String_Basep;
-                                        Len : Ghdl_Index_Type;
-                                        Is_Real : out Boolean;
-                                        Lit_Pos : out Ghdl_Index_Type;
-                                        Lit_End : out Ghdl_Index_Type;
-                                        Unit_Pos : out Ghdl_Index_Type);
-
    function Ghdl_Value_B1 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
       return Ghdl_B1;
    function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
diff --git a/src/synth/elab-memtype.adb b/src/synth/elab-memtype.adb
index c8234bb2b..8a9babd3d 100644
--- a/src/synth/elab-memtype.adb
+++ b/src/synth/elab-memtype.adb
@@ -42,6 +42,14 @@ package body Elab.Memtype is
       return To_U8_Ptr (To_Address (Mem)).all;
    end Read_U8;
 
+   type Char_Ptr is access all Character;
+   function To_Char_Ptr is new Ada.Unchecked_Conversion (Address, Char_Ptr);
+
+   function Read_Char (Mem : Memory_Ptr) return Character is
+   begin
+      return To_Char_Ptr (To_Address (Mem)).all;
+   end Read_Char;
+
    procedure Write_I32 (Mem : Memory_Ptr; Val : Ghdl_I32)
    is
       V : Ghdl_I32;
diff --git a/src/synth/elab-memtype.ads b/src/synth/elab-memtype.ads
index 2fc088d5e..ee562779a 100644
--- a/src/synth/elab-memtype.ads
+++ b/src/synth/elab-memtype.ads
@@ -44,6 +44,8 @@ package Elab.Memtype is
    procedure Write_U8 (Mem : Memory_Ptr; Val : Ghdl_U8);
    function Read_U8 (Mem : Memory_Ptr) return Ghdl_U8;
 
+   function Read_Char (Mem : Memory_Ptr) return Character;
+
    procedure Write_U32 (Mem : Memory_Ptr; Val : Ghdl_U32);
    function Read_U32 (Mem : Memory_Ptr) return Ghdl_U32;
 
diff --git a/src/synth/elab-vhdl_expr.adb b/src/synth/elab-vhdl_expr.adb
index c32601ef1..471e3f88d 100644
--- a/src/synth/elab-vhdl_expr.adb
+++ b/src/synth/elab-vhdl_expr.adb
@@ -40,7 +40,6 @@ with Grt.Types;
 with Grt.Vhdl_Types;
 with Grt.Strings;
 with Grt.To_Strings;
-with Grt.Values;
 with Grt.Vstrings;
 
 package body Elab.Vhdl_Expr is
@@ -102,16 +101,20 @@ package body Elab.Vhdl_Expr is
    end Exec_Subtype_Conversion;
 
    --  Return True iff ID = S, case insensitive.
-   function Match_Id (Id : Name_Id; S : String) return Boolean is
+   function Match_Id (Id : Name_Id; M : Memory_Ptr; Len : Natural)
+                     return Boolean is
    begin
-      if Name_Table.Get_Name_Length (Id) /= S'Length then
+      if Name_Table.Get_Name_Length (Id) /= Len then
          return False;
       end if;
       declare
-         Img : constant String (S'Range) := Name_Table.Image (Id);
+         Img : constant String (1 .. Len) := Name_Table.Image (Id);
+         C : Character;
       begin
          for I in Img'Range loop
-            if Grt.Strings.To_Lower (S (I)) /= Img (I) then
+            C := Read_Char (M + Size_Type (I - 1));
+            C := Grt.Strings.To_Lower (C);
+            if C /= Img (I) then
                return False;
             end if;
          end loop;
@@ -119,14 +122,163 @@ package body Elab.Vhdl_Expr is
       end;
    end Match_Id;
 
+   --  V is the string whose value should be extracted from.  ETYPE and DTYPE
+   --  are the type of the value.
+   function Value_Attribute (V : Valtyp; Etype : Node; Dtype : Type_Acc)
+                            return Valtyp
+   is
+      Btype : constant Node := Get_Base_Type (Etype);
+      M : constant Memory_Ptr := V.Val.Mem;
+      L : constant Uns32 := V.Typ.Abound.Len;
+      Len : Uns32;
+      First, Last : Size_Type;
+      Val : Int64;
+   begin
+      --  LRM93 14.1 Predefined attributes.
+      --  Leading and trailing whitespace are ignored.
+      First := 0;
+      Last := Size_Type (L - 1);
+      while First <= Last loop
+         exit when not Vhdl.Scanner.Is_Whitespace (Read_Char (M + First));
+         First := First + 1;
+      end loop;
+      while Last >= First loop
+         exit when not Vhdl.Scanner.Is_Whitespace (Read_Char (M + Last));
+         Last := Last - 1;
+      end loop;
+      Len := Uns32 (Last - First + 1);
+
+      case Get_Kind (Btype) is
+         when Iir_Kind_Enumeration_Type_Definition =>
+            declare
+               Id : Name_Id;
+               En : Node;
+            begin
+               if Len = 3
+                 and then Read_Char (M + First) = '''
+                 and then Read_Char (M + First + 2) = '''
+               then
+                  Id := Name_Table.Get_Identifier (Read_Char (M + First + 1));
+               else
+                  declare
+                     S : String (1 .. Natural (Len));
+                     C : Character;
+                  begin
+                     for I in S'Range loop
+                        C := Read_Char (M + First + Size_Type (I - 1));
+                        C := Grt.Strings.To_Lower (C);
+                        S (I) := C;
+                     end loop;
+                     Id := Name_Table.Get_Identifier_No_Create (S);
+                  end;
+               end if;
+               En := Find_Name_In_Flist
+                 (Get_Enumeration_Literal_List (Btype), Id);
+               if En = Null_Node then
+                  return No_Valtyp;
+               end if;
+               Val := Int64 (Get_Enum_Pos (En));
+            end;
+         when Iir_Kind_Integer_Type_Definition =>
+            declare
+               use Grt.To_Strings;
+               use Grt.Types;
+               use Grt.Vhdl_Types;
+               Res : Value_I64_Result;
+            begin
+               Res := Value_I64 (To_Std_String_Basep (To_Address (M + First)),
+                                 Ghdl_Index_Type (Len), 0);
+               if Res.Status /= Value_Ok then
+                  return No_Valtyp;
+               end if;
+               Val := Int64 (Res.Val);
+            end;
+         when Iir_Kind_Floating_Type_Definition =>
+            declare
+               use Grt.To_Strings;
+               use Grt.Types;
+               use Grt.Vhdl_Types;
+               Res : Value_F64_Result;
+            begin
+               Res := Value_F64 (To_Std_String_Basep (To_Address (M + First)),
+                                 Ghdl_Index_Type (Len), 0);
+               if Res.Status /= Value_Ok then
+                  return No_Valtyp;
+               end if;
+               return Create_Value_Float (Fp64 (Res.Val), Dtype);
+            end;
+         when Iir_Kind_Physical_Type_Definition =>
+            declare
+               use Grt.Types;
+               use Grt.Vhdl_Types;
+               use Grt.To_Strings;
+               Is_Real : Boolean;
+               Lit_Pos : Ghdl_Index_Type;
+               Lit_End : Ghdl_Index_Type;
+               Unit_Pos : Ghdl_Index_Type;
+               Unit_F : Size_Type;
+               Unit_Len : Natural;
+               Mult : Int64;
+               Unit : Iir;
+               Unit_Id : Name_Id;
+               Val_F : Grt.To_Strings.Value_F64_Result;
+               Val_I : Grt.To_Strings.Value_I64_Result;
+            begin
+               Grt.To_Strings.Ghdl_Value_Physical_Split
+                 (To_Std_String_Basep (To_Address (M)), Ghdl_Index_Type (L),
+                  Is_Real, Lit_Pos, Lit_End, Unit_Pos);
+               Unit_F := Size_Type (Unit_Pos);
+
+               --  Find unit.
+               Unit_Len := 0;
+               for I in Unit_F .. Last loop
+                  exit when Grt.Strings.Is_Whitespace (Read_Char (M + I));
+                  Unit_Len := Unit_Len + 1;
+               end loop;
+
+               Unit := Get_Primary_Unit (Btype);
+               while Unit /= Null_Iir loop
+                  Unit_Id := Get_Identifier (Unit);
+                  exit when Match_Id (Unit_Id, M + Unit_F, Unit_Len);
+                  Unit := Get_Chain (Unit);
+               end loop;
+
+               if Unit = Null_Iir then
+                  return No_Valtyp;
+               end if;
+               Mult := Get_Value (Get_Physical_Literal (Unit));
+
+               if Is_Real then
+                  Val_F := Value_F64 (To_Std_String_Basep (To_Address (M)),
+                                      Lit_End, Ghdl_Index_Type (First));
+                  if Val_F.Status /= Value_Ok then
+                     return No_Valtyp;
+                  end if;
+                  Val := Int64 (Val_F.Val * Ghdl_F64 (Mult));
+               else
+                  Val_I := Value_I64 (To_Std_String_Basep (To_Address (M)),
+                                      Lit_End, Ghdl_Index_Type (First));
+                  if Val_I.Status /= Value_Ok then
+                     return No_Valtyp;
+                  end if;
+                  Val := Int64 (Val_I.Val) * Mult;
+               end if;
+            end;
+
+         when others =>
+            raise Internal_Error;
+      end case;
+      return Create_Value_Discrete (Val, Dtype);
+   end Value_Attribute;
+
    function Exec_Value_Attribute (Syn_Inst : Synth_Instance_Acc; Attr : Node)
                                  return Valtyp
    is
       Param : constant Node := Get_Parameter (Attr);
       Etype : constant Node := Get_Type (Attr);
-      Btype : constant Node := Get_Base_Type (Etype);
       V : Valtyp;
       Dtype : Type_Acc;
+      Res : Valtyp;
    begin
       --  The value is supposed to be static.
       V := Synth_Expression (Syn_Inst, Param);
@@ -140,108 +292,11 @@ package body Elab.Vhdl_Expr is
          return No_Valtyp;
       end if;
 
-      declare
-         Value : constant String := Value_To_String (V);
-         First, Last : Integer;
-         Res_N : Node;
-         Val : Int64;
-      begin
-         --  LRM93 14.1 Predefined attributes.
-         --  Leading and trailing whitespace are ignored.
-         First := Value'First;
-         Last := Value'Last;
-         while First <= Last loop
-            exit when not Vhdl.Scanner.Is_Whitespace (Value (First));
-            First := First + 1;
-         end loop;
-         while Last >= First loop
-            exit when not Vhdl.Scanner.Is_Whitespace (Value (Last));
-            Last := Last - 1;
-         end loop;
-
-         case Get_Kind (Btype) is
-            when Iir_Kind_Enumeration_Type_Definition =>
-               Res_N := Eval_Value_Attribute
-                 (Value (First .. Last), Etype, Attr);
-               Val := Int64 (Get_Enum_Pos (Res_N));
-               Free_Iir (Res_N);
-            when Iir_Kind_Integer_Type_Definition =>
-               declare
-                  use Grt.To_Strings;
-                  use Grt.Types;
-                  use Grt.Vhdl_Types;
-                  Value1 : String renames Value (First .. Last);
-                  Res : Value_I64_Result;
-               begin
-                  Res := Value_I64 (To_Std_String_Basep (Value1'Address),
-                                    Value1'Length, 0);
-                  if Res.Status = Value_Ok then
-                     Val := Int64 (Res.Val);
-                  else
-                     Error_Msg_Synth
-                       (Syn_Inst, Attr, "incorrect 'value string");
-                     return No_Valtyp;
-                  end if;
-               end;
-            when Iir_Kind_Physical_Type_Definition =>
-               declare
-                  use Grt.Types;
-                  use Grt.Vhdl_Types;
-                  Value1 : String renames Value (First .. Last);
-                  F : constant Ghdl_Index_Type := Ghdl_Index_Type (First);
-                  S : constant Std_String_Basep :=
-                    To_Std_String_Basep (Value1'Address);
-                  Len : constant Ghdl_Index_Type :=
-                    Ghdl_Index_Type (Last - First + 1);
-                  Is_Real : Boolean;
-                  Lit_Pos : Ghdl_Index_Type;
-                  Lit_End : Ghdl_Index_Type;
-                  Unit_Pos : Ghdl_Index_Type;
-                  Unit_F, Unit_L : Positive;
-                  Mult : Int64;
-                  Unit : Iir;
-                  Unit_Id : Name_Id;
-                  Val_F : Grt.To_Strings.Value_F64_Result;
-               begin
-                  Grt.Values.Ghdl_Value_Physical_Split
-                    (S, Len, Is_Real, Lit_Pos, Lit_End, Unit_Pos);
-                  Unit_F := Positive (Unit_Pos + 1);
-
-                  --  Find unit.
-                  Unit_L := Unit_F;
-                  for I in Unit_F .. Last loop
-                     exit when Grt.Strings.Is_Whitespace (Value1 (I));
-                     Unit_L := I;
-                  end loop;
-
-                  Unit := Get_Primary_Unit (Btype);
-                  while Unit /= Null_Iir loop
-                     Unit_Id := Get_Identifier (Unit);
-                     exit when Match_Id (Unit_Id, Value1 (Unit_F .. Unit_L));
-                     Unit := Get_Chain (Unit);
-                  end loop;
-
-                  if Unit = Null_Iir then
-                     Error_Msg_Synth (Syn_Inst, Attr, "incorrect unit name");
-                     return No_Valtyp;
-                  end if;
-                  Mult := Get_Value (Get_Physical_Literal (Unit));
-
-                  if Is_Real then
-                     Val_F := Grt.To_Strings.Value_F64 (S, Lit_End, F);
-                     Val := Int64 (Val_F.Val * Ghdl_F64 (Mult));
-                  else
-                     Val := Int64 (Grt.Values.Value_I64 (S, Lit_End, F))
-                       * Mult;
-                  end if;
-               end;
-
-            when others =>
-               Error_Msg_Elab (+Attr, "unhandled type for 'value");
-               return No_Valtyp;
-         end case;
-         return Create_Value_Discrete (Val, Dtype);
-      end;
+      Res := Value_Attribute (V, Etype, Dtype);
+      if Res = No_Valtyp then
+         Error_Msg_Synth (Syn_Inst, Attr, "incorrect 'value string");
+      end if;
+      return Res;
    end Exec_Value_Attribute;
 
    function Synth_Image_Attribute_Str (Val : Valtyp; Expr_Type : Iir)