generic override: handle enumerated types.

9 files changed, 142 insertions, 15 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");
diff --git a/testsuite/gna/ticket37/genbool.vhdl b/testsuite/gna/ticket37/genbool.vhdl
new file mode 100644
index 000000000..438da77a5
--- /dev/null
+++ b/testsuite/gna/ticket37/genbool.vhdl
@@ -0,0 +1,8 @@
+entity genbool is
+  generic (val : boolean := False);
+end genbool;
+
+architecture behav of genbool is
+begin
+  assert val severity failure;
+end behav;
diff --git a/testsuite/gna/ticket37/genchar.vhdl b/testsuite/gna/ticket37/genchar.vhdl
new file mode 100644
index 000000000..fa1491971
--- /dev/null
+++ b/testsuite/gna/ticket37/genchar.vhdl
@@ -0,0 +1,8 @@
+entity genchar is
+  generic (val : character := CR);
+end genchar;
+
+architecture behav of genchar is
+begin
+  assert val = Ack or val = 'A' or val = 'z' severity failure;
+end behav;
diff --git a/testsuite/gna/ticket37/genint.vhdl b/testsuite/gna/ticket37/genint.vhdl
index 742d1093e..51ac559af 100644
--- a/testsuite/gna/ticket37/genint.vhdl
+++ b/testsuite/gna/ticket37/genint.vhdl
@@ -12,4 +12,3 @@ architecture behav of genint is
 begin
   assert val = -159 or val = 9 severity failure;
 end behav;
-  
diff --git a/testsuite/gna/ticket37/genlogic.vhdl b/testsuite/gna/ticket37/genlogic.vhdl
new file mode 100644
index 000000000..b64d21f9e
--- /dev/null
+++ b/testsuite/gna/ticket37/genlogic.vhdl
@@ -0,0 +1,11 @@
+library ieee;
+use ieee.std_logic_1164.all;
+
+entity genlogic is
+  generic (val : std_logic := '0');
+end genlogic;
+
+architecture behav of genlogic is
+begin
+  assert val = '1' or val = 'H' severity failure;
+end behav;
diff --git a/testsuite/gna/ticket37/testsuite.sh b/testsuite/gna/ticket37/testsuite.sh
index 0bbd20769..f662f7117 100755
--- a/testsuite/gna/ticket37/testsuite.sh
+++ b/testsuite/gna/ticket37/testsuite.sh
@@ -15,6 +15,28 @@ simulate genint -gVal=-159
 
 simulate_failure genint -gval=200
 
+analyze genchar.vhdl
+elab_simulate_failure genchar
+
+simulate genchar -gVAL=ack
+simulate genchar -gVAL="'A'"
+simulate genchar -gVAL="'z'"
+simulate_failure genchar -gVAL="'0'"
+simulate_failure genchar -gVAL=A
+
+analyze genbool.vhdl
+elab_simulate_failure genbool
+
+simulate genbool -gval=true
+simulate genbool -gval=" True"
+
+analyze genlogic.vhdl
+elab_simulate_failure genlogic
+
+simulate genlogic -gvaL="'1'"
+simulate genlogic -gvaL="'H'"
+simulate_failure genlogic -gvaL="'L'"
+
 clean
 
 echo "Test successful"
diff --git a/testsuite/testenv.sh b/testsuite/testenv.sh
index ed19a398b..e42d7fd97 100644
--- a/testsuite/testenv.sh
+++ b/testsuite/testenv.sh
@@ -66,7 +66,7 @@ elab_failure ()
 simulate ()
 {
    echo "simulate $@ ($GHDL_FLAGS $@ $GHDL_SIMFLAGS)" >&2
-   $GHDL -r $GHDL_STD_FLAGS $GHDL_FLAGS $@ $GHDL_SIMFLAGS
+   $GHDL -r $GHDL_STD_FLAGS $GHDL_FLAGS "$@" $GHDL_SIMFLAGS
    #./$@
 }