generic override: handle enumerated types.

3 files changed, 92 insertions, 13 deletions

diff --git a/src/grt/grt-change_generics.adb b/src/grt/grt-change_generics.adb
index f181e1ad8..7bf5e49e5 100644
--- a/src/grt/grt-change_generics.adb
+++ b/src/grt/grt-change_generics.adb
@@ -148,8 +148,8 @@ package body Grt.Change_Generics is
    end Override_Generic_Array;
 
    procedure Override_Generic_I32 (Obj_Rti : Ghdl_Rtin_Object_Acc;
-                                     Ctxt : Rti_Context;
-                                     Over : Generic_Override_Acc)
+                                   Ctxt : Rti_Context;
+                                   Over : Generic_Override_Acc)
    is
       Subtype_Rti : constant Ghdl_Rtin_Subtype_Scalar_Acc :=
         To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj_Rti.Obj_Type);
@@ -184,6 +184,62 @@ package body Grt.Change_Generics is
       Ptr.I32 := Ghdl_I32 (Res);
    end Override_Generic_I32;
 
+   procedure Override_Generic_Enum (Obj_Rti : Ghdl_Rtin_Object_Acc;
+                                    Ctxt : Rti_Context;
+                                    Over : Generic_Override_Acc;
+                                    Type_Rti : Ghdl_Rti_Access)
+   is
+      Res : Ghdl_Index_Type;
+      Ptr : Ghdl_Value_Ptr;
+   begin
+      Res := Grt.Values.Value_Enum
+        (To_Std_String_Basep (Over.Value.all'Address),
+         Over.Value'Length, Type_Rti);
+
+      --  Assign.
+      Ptr := To_Ghdl_Value_Ptr
+        (Loc_To_Addr (Obj_Rti.Common.Depth, Obj_Rti.Loc, Ctxt));
+
+      case Obj_Rti.Obj_Type.Kind is
+         when Ghdl_Rtik_Type_E8 =>
+            Ptr.E8 := Ghdl_E8 (Res);
+         when Ghdl_Rtik_Type_B1 =>
+            Ptr.B1 := Ghdl_B1'Val (Res);
+         when Ghdl_Rtik_Subtype_Scalar =>
+            declare
+               Subtype_Rti : constant Ghdl_Rtin_Subtype_Scalar_Acc :=
+                 To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj_Rti.Obj_Type);
+               Rng : Ghdl_Range_Ptr;
+            begin
+               Rng := To_Ghdl_Range_Ptr
+                 (Loc_To_Addr (Subtype_Rti.Common.Depth,
+                               Subtype_Rti.Range_Loc, Ctxt));
+               case Subtype_Rti.Basetype.Kind is
+                  when Ghdl_Rtik_Type_E8 =>
+                     case Rng.E8.Dir is
+                        when Dir_To =>
+                           if Res < Ghdl_Index_Type (Rng.E8.Left)
+                             or else Res > Ghdl_Index_Type (Rng.E8.Right)
+                           then
+                              Error_Range (Over);
+                           end if;
+                        when Dir_Downto =>
+                           if Res > Ghdl_Index_Type (Rng.E8.Left)
+                             or else Res < Ghdl_Index_Type (Rng.E8.Right)
+                           then
+                              Error_Range (Over);
+                           end if;
+                     end case;
+                     Ptr.E8 := Ghdl_E8 (Res);
+                  when others =>
+                     Internal_Error ("override_generic_enum");
+               end case;
+            end;
+         when others =>
+            Internal_Error ("override_generic_enum");
+      end case;
+   end Override_Generic_Enum;
+
    --  Override DECL with OVER.  Dispatch according to generic type.
    procedure Override_Generic_Value (Decl : VhpiHandleT;
                                      Over : Generic_Override_Acc)
@@ -198,6 +254,9 @@ package body Grt.Change_Generics is
       case Type_Rti.Kind is
          when Ghdl_Rtik_Type_Array =>
             Override_Generic_Array (Obj_Rti, Ctxt, Over);
+         when Ghdl_Rtik_Type_B1
+           | Ghdl_Rtik_Type_E8 =>
+            Override_Generic_Enum (Obj_Rti, Ctxt, Over, Type_Rti);
          when Ghdl_Rtik_Subtype_Scalar =>
             declare
                Subtype_Rti : constant Ghdl_Rtin_Subtype_Scalar_Acc :=
@@ -206,6 +265,9 @@ package body Grt.Change_Generics is
                case Subtype_Rti.Basetype.Kind is
                   when Ghdl_Rtik_Type_I32 =>
                      Override_Generic_I32 (Obj_Rti, Ctxt, Over);
+                  when Ghdl_Rtik_Type_E8 =>
+                     Override_Generic_Enum
+                       (Obj_Rti, Ctxt, Over, Subtype_Rti.Basetype);
                   when others =>
                      Error_Override
                        ("unhandled type for generic override of", Over);
diff --git a/src/grt/grt-values.adb b/src/grt/grt-values.adb
index 77699f6ac..18a917bd2 100644
--- a/src/grt/grt-values.adb
+++ b/src/grt/grt-values.adb
@@ -77,17 +77,22 @@ package body Grt.Values is
                           Len : Ghdl_Index_Type;
                           Ref : Ghdl_C_String) return Boolean
    is
+      Is_Char : constant Boolean := S (Pos) = ''';
       P : Ghdl_Index_Type;
-      C : Character;
+      C_Ref, C_S : Character;
    begin
       P := 0;
       loop
-         C := Ref (Natural (P + 1));
+         C_Ref := Ref (Natural (P + 1));
          if Pos + P = Len then
             --  End of string.
-            return C = ASCII.NUL;
+            return C_Ref = ASCII.NUL;
+         end if;
+         C_S := S (Pos + P);
+         if not Is_Char then
+            C_S := To_LC (C_S);
          end if;
-         if To_LC (S (Pos + P)) /= C or else C = ASCII.NUL then
+         if C_S /= C_Ref or else C_Ref = ASCII.NUL then
             return False;
          end if;
          P := P + 1;
@@ -95,27 +100,35 @@ package body Grt.Values is
    end String_Match;
 
    --  Return the value of STR for enumerated type RTI.
-   function Ghdl_Value_Enum (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+   function Value_Enum
+     (S : Std_String_Basep; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access)
       return Ghdl_Index_Type
    is
       Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc :=
         To_Ghdl_Rtin_Type_Enum_Acc (Rti);
-      S     : constant Std_String_Basep := Str.Base;
-      Len   : Ghdl_Index_Type  := Str.Bounds.Dim_1.Length;
-      Pos   : Ghdl_Index_Type := 0;
+      Pos : Ghdl_Index_Type;
+      L : Ghdl_Index_Type;
    begin
-      Remove_Whitespaces (S, Len, Pos);
+      Pos := 0;
+      L := Len;
+      Remove_Whitespaces (S, L, Pos);
 
       for I in 0 .. Enum_Rti.Nbr - 1 loop
-         if String_Match (S, Pos, Len, Enum_Rti.Names (I)) then
+         if String_Match (S, Pos, L, Enum_Rti.Names (I)) then
             return I;
          end if;
       end loop;
       Error_C ("'value: '");
-      Error_C_Std (S (Pos .. Len));
+      Error_C_Std (S (Pos .. L));
       Error_C ("' not in enumeration '");
       Error_C (Enum_Rti.Name);
       Error_E ("'");
+   end Value_Enum;
+
+   function Ghdl_Value_Enum (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+      return Ghdl_Index_Type is
+   begin
+      return Value_Enum (Str.Base, Str.Bounds.Dim_1.Length, Rti);
    end Ghdl_Value_Enum;
 
    function Ghdl_Value_B1 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
diff --git a/src/grt/grt-values.ads b/src/grt/grt-values.ads
index b1747b4e0..5f1e5169d 100644
--- a/src/grt/grt-values.ads
+++ b/src/grt/grt-values.ads
@@ -63,6 +63,10 @@ package Grt.Values is
      (S : Std_String_Basep; Len : Ghdl_Index_Type; Init_Pos : Ghdl_Index_Type)
      return Ghdl_I64;
 
+   --  Return the value of STR for enumerated type RTI.
+   function Value_Enum
+     (S : Std_String_Basep; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access)
+     return Ghdl_Index_Type;
 private
    pragma Export (Ada, Ghdl_Value_B1, "__ghdl_value_b1");
    pragma Export (C, Ghdl_Value_E8, "__ghdl_value_e8");