diff options
| -rw-r--r-- | src/grt/grt-change_generics.adb | 58 | ||||
| -rw-r--r-- | src/grt/grt-values.adb | 46 | ||||
| -rw-r--r-- | src/grt/grt-values.ads | 8 | ||||
| -rw-r--r-- | testsuite/gna/ticket37/genint.vhdl | 15 | ||||
| -rwxr-xr-x | testsuite/gna/ticket37/testsuite.sh | 8 |
5 files changed, 120 insertions, 15 deletions
diff --git a/src/grt/grt-change_generics.adb b/src/grt/grt-change_generics.adb index bbec5e47f..f181e1ad8 100644 --- a/src/grt/grt-change_generics.adb +++ b/src/grt/grt-change_generics.adb @@ -31,16 +31,22 @@ with Grt.Avhpi_Utils; use Grt.Avhpi_Utils; with Grt.Errors; use Grt.Errors; with Grt.Rtis; use Grt.Rtis; with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Values; package body Grt.Change_Generics is procedure Error_Override (Msg : String; Over : Generic_Override_Acc) is begin Error_C (Msg); - Error_E (" '"); + Error_C (" '"); Error_C (Over.Name.all); Error_E ("'"); end Error_Override; + procedure Error_Range (Over : Generic_Override_Acc) is + begin + Error_Override ("value not in range for generic", Over); + end Error_Range; + -- Convert C to E8 values procedure Ghdl_Value_E8_Char (Res : out Ghdl_E8; Err : out Boolean; @@ -141,6 +147,43 @@ package body Grt.Change_Generics is Bounds => Rng.all'Address); end Override_Generic_Array; + procedure Override_Generic_I32 (Obj_Rti : Ghdl_Rtin_Object_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); + Rng : Ghdl_Range_Ptr; + Res : Ghdl_I64; + Ptr : Ghdl_Value_Ptr; + begin + Res := Grt.Values.Value_I64 + (To_Std_String_Basep (Over.Value.all'Address), Over.Value'Length, 0); + + -- Check range. + Rng := To_Ghdl_Range_Ptr + (Loc_To_Addr (Subtype_Rti.Common.Depth, Subtype_Rti.Range_Loc, Ctxt)); + case Rng.I32.Dir is + when Dir_To => + if Res < Ghdl_I64 (Rng.I32.Left) + or else Res > Ghdl_I64 (Rng.I32.Right) + then + Error_Range (Over); + end if; + when Dir_Downto => + if Res > Ghdl_I64 (Rng.I32.Left) + or else Res < Ghdl_I64 (Rng.I32.Right) + then + Error_Range (Over); + end if; + end case; + + -- Assign. + Ptr := To_Ghdl_Value_Ptr + (Loc_To_Addr (Obj_Rti.Common.Depth, Obj_Rti.Loc, Ctxt)); + Ptr.I32 := Ghdl_I32 (Res); + end Override_Generic_I32; + -- Override DECL with OVER. Dispatch according to generic type. procedure Override_Generic_Value (Decl : VhpiHandleT; Over : Generic_Override_Acc) @@ -155,6 +198,19 @@ 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_Subtype_Scalar => + declare + Subtype_Rti : constant Ghdl_Rtin_Subtype_Scalar_Acc := + To_Ghdl_Rtin_Subtype_Scalar_Acc (Type_Rti); + begin + case Subtype_Rti.Basetype.Kind is + when Ghdl_Rtik_Type_I32 => + Override_Generic_I32 (Obj_Rti, Ctxt, Over); + when others => + Error_Override + ("unhandled type for generic override of", Over); + end case; + end; when others => Error_Override ("unhandled type for generic override of", Over); end case; diff --git a/src/grt/grt-values.adb b/src/grt/grt-values.adb index 2454e175e..9d7cf2036 100644 --- a/src/grt/grt-values.adb +++ b/src/grt/grt-values.adb @@ -140,29 +140,42 @@ package body Grt.Values is end Ghdl_Value_E32; -- Convert S (INIT_POS .. LEN) to a signed integer. - function Ghdl_Value_I64 (S : Std_String_Basep; - Len : Ghdl_Index_Type; - Init_Pos : Ghdl_Index_Type) - return Ghdl_I64 + function Value_I64 + (S : Std_String_Basep; Len : Ghdl_Index_Type; Init_Pos : Ghdl_Index_Type) + return Ghdl_I64 is Pos : Ghdl_Index_Type := Init_Pos; C : Character; Sep : Character; Val, D, Base : Ghdl_I64; Exp : Integer; + Is_Neg : Boolean; begin C := S (Pos); - -- Be user friendly. - -- FIXME: reference. - if C = '-' or C = '+' then - Error_E ("'value: leading sign +/- not allowed"); + -- LRM02 14.1 Predefined attributes + -- Restrictions: It is an error is the parameter is not a valid string + -- representation of a literal ot type T. + -- + -- Apparently there is no definition of 'string representation', the + -- closest is: + -- + -- LRM02 14.3 Package TEXTIO + -- The representation of both INTEGER and REAL values [...] + Is_Neg := False; + if C = '+' or C = '-' then + if Pos = Len then + Error_E ("'value: missing digit after +/-"); + end if; + Pos := Pos + 1; + Is_Neg := C = '-'; + C := S (Pos); end if; Val := 0; loop if C in '0' .. '9' then - Val := Val * 10 + Character'Pos (C) - Character'Pos ('0'); + Val := Val * 10 - (Character'Pos (C) - Character'Pos ('0')); Pos := Pos + 1; exit when Pos >= Len; C := S (Pos); @@ -192,6 +205,9 @@ package body Grt.Values is end loop; if Pos >= Len then + if not Is_Neg then + Val := -Val; + end if; return Val; end if; @@ -221,7 +237,7 @@ package body Grt.Values is if D >= Base then Error_E ("'value: digit >= base"); end if; - Val := Val * Base + D; + Val := Val * Base - D; Pos := Pos + 1; if Pos >= Len then Error_E ("'value: missing end sign number"); @@ -300,8 +316,12 @@ package body Grt.Values is Error_E ("'value: trailing characters after blank"); end if; + if not Is_Neg then + Val := -Val; + end if; + return Val; - end Ghdl_Value_I64; + end Value_I64; function Ghdl_Value_I64 (Str : Std_String_Ptr) return Ghdl_I64 is @@ -315,7 +335,7 @@ package body Grt.Values is -- GHDL: allow several leading whitespace. Remove_Whitespaces (S, Len, Pos); - return Ghdl_Value_I64 (S, Len, Pos); + return Value_I64 (S, Len, Pos); end Ghdl_Value_I64; function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32 @@ -611,7 +631,7 @@ package body Grt.Values is return Ghdl_I64 (Ghdl_Value_F64 (S, Lit_End, Lit_Pos) * Ghdl_F64 (Mult)); else - return Ghdl_Value_I64 (S, Lit_End, Lit_Pos) * Mult; + return Value_I64 (S, Lit_End, Lit_Pos) * Mult; end if; end if; end Ghdl_Value_Physical_Type; diff --git a/src/grt/grt-values.ads b/src/grt/grt-values.ads index 8df8c3f63..b1747b4e0 100644 --- a/src/grt/grt-values.ads +++ b/src/grt/grt-values.ads @@ -56,7 +56,13 @@ package Grt.Values is function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) return Ghdl_I64; function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) - return Ghdl_I32; + return Ghdl_I32; + + -- Convert S (INIT_POS .. LEN) to a signed integer. + function Value_I64 + (S : Std_String_Basep; Len : Ghdl_Index_Type; Init_Pos : Ghdl_Index_Type) + return Ghdl_I64; + 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/genint.vhdl b/testsuite/gna/ticket37/genint.vhdl new file mode 100644 index 000000000..742d1093e --- /dev/null +++ b/testsuite/gna/ticket37/genint.vhdl @@ -0,0 +1,15 @@ +package pkg is + subtype myint is integer range integer'low to 169; +end pkg; + +use work.pkg.all; + +entity genint is + generic (val : myint := 5); +end genint; + +architecture behav of genint is +begin + assert val = -159 or val = 9 severity failure; +end behav; + diff --git a/testsuite/gna/ticket37/testsuite.sh b/testsuite/gna/ticket37/testsuite.sh index ea51e5c79..0bbd20769 100755 --- a/testsuite/gna/ticket37/testsuite.sh +++ b/testsuite/gna/ticket37/testsuite.sh @@ -7,6 +7,14 @@ elab_simulate dispgen elab_simulate dispgen -gstr=Hello +analyze genint.vhdl +elab_simulate_failure genint + +simulate genint -gVAL=9 +simulate genint -gVal=-159 + +simulate_failure genint -gval=200 + clean echo "Test successful" |