diff options
| -rw-r--r-- | src/grt/grt-change_generics.adb | 52 | ||||
| -rw-r--r-- | src/grt/grt-change_generics.ads | 4 | ||||
| -rw-r--r-- | src/grt/grt-main.adb | 1 | ||||
| -rw-r--r-- | src/libraries.adb | 2 | ||||
| -rw-r--r-- | src/vhdl/configuration.adb | 47 | ||||
| -rw-r--r-- | src/vhdl/translate/trans-chap1.adb | 19 | ||||
| -rw-r--r-- | testsuite/gna/ticket49/bug.vhdl | 22 | ||||
| -rwxr-xr-x | testsuite/gna/ticket49/testsuite.sh | 9 |
8 files changed, 152 insertions, 4 deletions
diff --git a/src/grt/grt-change_generics.adb b/src/grt/grt-change_generics.adb index 7bf5e49..dc273c5 100644 --- a/src/grt/grt-change_generics.adb +++ b/src/grt/grt-change_generics.adb @@ -23,6 +23,7 @@ -- however invalidate any other reasons why the executable file might be -- covered by the GNU Public License. +with System; with Grt.Types; use Grt.Types; with Grt.Lib; use Grt.Lib; with Grt.Options; use Grt.Options; @@ -322,4 +323,55 @@ package body Grt.Change_Generics is Over := Over.Next; end loop; end Change_All_Generics; + + procedure Check_Required_Generic_Override + is + Root, It, Decl : VhpiHandleT; + Error : AvhpiErrorT; + begin + Get_Root_Inst (Root); + + -- Find generic. + Vhpi_Iterator (VhpiDecls, Root, It, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("override_generic(1)"); + return; + end if; + + -- Look for the generic. + loop + Vhpi_Scan (It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Internal_Error ("override_generic(2)"); + return; + end if; + exit when Vhpi_Get_Kind (Decl) /= VhpiGenericDeclK; + + declare + use System; + Rti : constant Ghdl_Rti_Access := Avhpi_Get_Rti (Decl); + Obj_Rti : constant Ghdl_Rtin_Object_Acc := + To_Ghdl_Rtin_Object_Acc (Rti); + Type_Rti : constant Ghdl_Rti_Access := Obj_Rti.Obj_Type; + Ctxt : constant Rti_Context := Avhpi_Get_Context (Decl); + begin + pragma Assert (Rti.Kind = Ghdl_Rtik_Generic); + if Type_Rti.Kind = Ghdl_Rtik_Type_Array then + declare + Uc_Array : Ghdl_Uc_Array_Acc; + begin + Uc_Array := To_Ghdl_Uc_Array_Acc + (Loc_To_Addr (Obj_Rti.Common.Depth, Obj_Rti.Loc, Ctxt)); + if Uc_Array.Base = Null_Address then + Error_C ("top-level generic '"); + Error_C (Obj_Rti.Name); + Error_E ("' must be overriden (use -gGEN=VAL)"); + end if; + end; + end if; + end; + end loop; + end Check_Required_Generic_Override; + end Grt.Change_Generics; diff --git a/src/grt/grt-change_generics.ads b/src/grt/grt-change_generics.ads index e3439b4..d2dec9b 100644 --- a/src/grt/grt-change_generics.ads +++ b/src/grt/grt-change_generics.ads @@ -26,4 +26,8 @@ package Grt.Change_Generics is -- Override top entity generics, using Generic_Override list from Options. procedure Change_All_Generics; + + -- Emit an error if a generic that required override (unconstrained array) + -- wasn't overriden. + procedure Check_Required_Generic_Override; end Grt.Change_Generics; diff --git a/src/grt/grt-main.adb b/src/grt/grt-main.adb index ad21a24..6d595b4 100644 --- a/src/grt/grt-main.adb +++ b/src/grt/grt-main.adb @@ -64,6 +64,7 @@ package body Grt.Main is procedure Ghdl_Init_Top_Generics is begin Grt.Change_Generics.Change_All_Generics; + Grt.Change_Generics.Check_Required_Generic_Override; end Ghdl_Init_Top_Generics; procedure Disp_Stats_Hook (Code : Integer); diff --git a/src/libraries.adb b/src/libraries.adb index 0cca4d0..e01a9bc 100644 --- a/src/libraries.adb +++ b/src/libraries.adb @@ -236,7 +236,7 @@ package body Libraries is -- design_file_format ::= -- filename_format { design_unit_format } -- filename_format ::= - -- FILE directory "FILENAME" file_time_stamp analyze_time_stamp: + -- FILE directory "filename" "file_time_stamp" "analyze_time_stamp": -- design_unit_format ::= entity_format -- | architecture_format -- | package_format diff --git a/src/vhdl/configuration.adb b/src/vhdl/configuration.adb index 9ca2793..37817da 100644 --- a/src/vhdl/configuration.adb +++ b/src/vhdl/configuration.adb @@ -595,6 +595,49 @@ package body Configuration is is Has_Error : Boolean := False; + -- Return TRUE if GRT supports override of generic GEN. + function Allow_Generic_Override (Gen : Iir) return Boolean + is + Gen_Type : constant Iir := Get_Type (Gen); + begin + case Get_Kind (Gen_Type) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + return True; + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + -- Only one-dimensional arrays of enumeration are allowed. + -- If unconstrained, the index must be of integer type. + if Get_Kind (Get_Base_Type (Get_Element_Subtype (Gen_Type))) + /= Iir_Kind_Enumeration_Type_Definition + then + -- Not an array of enumeration type. + return False; + end if; + declare + Indexes : constant Iir_List := + Get_Index_Subtype_List (Gen_Type); + begin + if Get_Nbr_Elements (Indexes) /= 1 then + -- Not a one-dimensional array. + return False; + end if; + if Get_Constraint_State (Gen_Type) /= Fully_Constrained + and then (Get_Kind (Get_Index_Type (Indexes, 0)) + /= Iir_Kind_Integer_Subtype_Definition) + then + -- Index not constrained or not of integer subtype. + return False; + end if; + end; + return True; + when others => + return False; + end case; + end Allow_Generic_Override; + procedure Error (Msg : String; Loc : Iir) is begin if not Has_Error then @@ -611,7 +654,9 @@ package body Configuration is El := Get_Generic_Chain (Entity); while El /= Null_Iir loop if Get_Default_Value (El) = Null_Iir then - Error ("(" & Disp_Node (El) & " has no default value)", El); + if not Allow_Generic_Override (El) then + Error ("(" & Disp_Node (El) & " has no default value)", El); + end if; end if; El := Get_Chain (El); end loop; diff --git a/src/vhdl/translate/trans-chap1.adb b/src/vhdl/translate/trans-chap1.adb index 8d60992..35cbfb0 100644 --- a/src/vhdl/translate/trans-chap1.adb +++ b/src/vhdl/translate/trans-chap1.adb @@ -41,14 +41,29 @@ package body Trans.Chap1 is procedure Translate_Entity_Init_Generics (Entity : Iir) is - El : Iir; + El : Iir; begin Push_Local_Factory; El := Get_Generic_Chain (Entity); while El /= Null_Iir loop Open_Temp; - Chap4.Elab_Object_Value (El, Get_Default_Value (El)); + + declare + Val : constant Iir := Get_Default_Value (El); + El_Type : constant Iir := Get_Type (El); + begin + if Val = Null_Iir + and then Get_Kind (El_Type) in Iir_Kinds_Array_Type_Definition + and then Get_Constraint_State (El_Type) /= Fully_Constrained + then + -- Do not initialize unconstrained array. They will have + -- to be overriden by user. + null; + else + Chap4.Elab_Object_Value (El, Val); + end if; + end; Close_Temp; El := Get_Chain (El); end loop; diff --git a/testsuite/gna/ticket49/bug.vhdl b/testsuite/gna/ticket49/bug.vhdl new file mode 100644 index 0000000..45f66c3 --- /dev/null +++ b/testsuite/gna/ticket49/bug.vhdl @@ -0,0 +1,22 @@ +entity ent is +end entity; + +architecture a of ent is + procedure set(x : integer; value : integer := 0) is + begin + end procedure; + + procedure set(x : integer; y : integer; value : integer := 0) is + begin + end procedure; + + procedure set(x : integer; y : integer; z : integer; value : integer := 0) is + begin + end procedure; +begin + main : process + begin + set(0, value => 1); -- Works + set(0, 1, value => 1); -- Does not work + end process; +end architecture; diff --git a/testsuite/gna/ticket49/testsuite.sh b/testsuite/gna/ticket49/testsuite.sh new file mode 100755 index 0000000..c2417d1 --- /dev/null +++ b/testsuite/gna/ticket49/testsuite.sh @@ -0,0 +1,9 @@ +#! /bin/sh + +. ../../testenv.sh + +analyze bug.vhdl + +clean + +echo "Test successful" |