diff options
Diffstat (limited to 'src/grt')
| -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 |
3 files changed, 92 insertions, 13 deletions
diff --git a/src/grt/grt-change_generics.adb b/src/grt/grt-change_generics.adb index f181e1a..7bf5e49 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 77699f6..18a917b 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 b1747b4..5f1e516 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"); |