diff options
| -rw-r--r-- | src/grt/grt-change_generics.adb | 66 | ||||
| -rw-r--r-- | src/grt/grt-values.adb | 35 | ||||
| -rw-r--r-- | src/grt/grt-values.ads | 4 | ||||
| -rw-r--r-- | testsuite/gna/ticket37/genbool.vhdl | 8 | ||||
| -rw-r--r-- | testsuite/gna/ticket37/genchar.vhdl | 8 | ||||
| -rw-r--r-- | testsuite/gna/ticket37/genint.vhdl | 1 | ||||
| -rw-r--r-- | testsuite/gna/ticket37/genlogic.vhdl | 11 | ||||
| -rwxr-xr-x | testsuite/gna/ticket37/testsuite.sh | 22 | ||||
| -rw-r--r-- | testsuite/testenv.sh | 2 |
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 #./$@ } |