diff options
| -rw-r--r-- | src/grt/grt-avhpi.adb | 3 | ||||
| -rw-r--r-- | src/grt/grt-avhpi_utils.adb | 65 | ||||
| -rw-r--r-- | src/grt/grt-avhpi_utils.ads | 38 | ||||
| -rw-r--r-- | src/grt/grt-change_generics.adb | 207 | ||||
| -rw-r--r-- | src/grt/grt-change_generics.ads | 29 | ||||
| -rw-r--r-- | src/grt/grt-main.adb | 3 | ||||
| -rw-r--r-- | src/grt/grt-options.adb | 46 | ||||
| -rw-r--r-- | src/grt/grt-options.ads | 18 | ||||
| -rw-r--r-- | src/grt/grt-values.adb | 2 | ||||
| -rw-r--r-- | src/grt/grt-vital_annotate.adb | 36 | ||||
| -rw-r--r-- | testsuite/gna/ticket37/dispgen.vhdl | 8 | ||||
| -rwxr-xr-x | testsuite/gna/ticket37/testsuite.sh | 12 |
12 files changed, 430 insertions, 37 deletions
diff --git a/src/grt/grt-avhpi.adb b/src/grt/grt-avhpi.adb index af2dc1b..535cb0a 100644 --- a/src/grt/grt-avhpi.adb +++ b/src/grt/grt-avhpi.adb @@ -1166,7 +1166,8 @@ package body Grt.Avhpi is | VhpiEnumTypeDeclK => return Obj.Atype; when VhpiSigDeclK - | VhpiPortDeclK => + | VhpiPortDeclK + | VhpiGenericDeclK => return To_Ghdl_Rti_Access (Obj.Obj); when others => return null; diff --git a/src/grt/grt-avhpi_utils.adb b/src/grt/grt-avhpi_utils.adb new file mode 100644 index 0000000..6fedf1b --- /dev/null +++ b/src/grt/grt-avhpi_utils.adb @@ -0,0 +1,65 @@ +-- GHDL Run Time (GRT) - Utility functions for AVHPI. +-- Copyright (C) 2015 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +with Grt.Errors; use Grt.Errors; + +package body Grt.Avhpi_Utils is + function Get_Root_Entity (Root : VhpiHandleT) return VhpiHandleT + is + Hdl : VhpiHandleT; + Error : AvhpiErrorT; + begin + Vhpi_Handle (VhpiDesignUnit, Root, Hdl, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("VhpiDesignUnit"); + end if; + + case Vhpi_Get_Kind (Hdl) is + when VhpiArchBodyK => + Vhpi_Handle (VhpiPrimaryUnit, Hdl, Hdl, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("VhpiPrimaryUnit"); + end if; + when others => + Internal_Error ("get_root_entity"); + end case; + return Hdl; + end Get_Root_Entity; + + function Name_Compare (Handle : VhpiHandleT; + Name : String; + Property : VhpiStrPropertyT := VhpiNameP) + return Boolean + is + Obj_Name : String (1 .. Name'Length); + Len : Natural; + begin + Vhpi_Get_Str (Property, Handle, Obj_Name, Len); + return Len = Name'Length and then Obj_Name = Name; + end Name_Compare; + +end Grt.Avhpi_Utils; + + diff --git a/src/grt/grt-avhpi_utils.ads b/src/grt/grt-avhpi_utils.ads new file mode 100644 index 0000000..d16b9c2 --- /dev/null +++ b/src/grt/grt-avhpi_utils.ads @@ -0,0 +1,38 @@ +-- GHDL Run Time (GRT) - Utility functions for AVHPI. +-- Copyright (C) 2015 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +with Grt.Avhpi; use Grt.Avhpi; + +package Grt.Avhpi_Utils is + function Get_Root_Entity (Root : VhpiHandleT) return VhpiHandleT; + + -- Return TRUE if name of HANDLE (using PROPERTY) is NAME. + function Name_Compare (Handle : VhpiHandleT; + Name : String; + Property : VhpiStrPropertyT := VhpiNameP) + return Boolean; +end Grt.Avhpi_Utils; + + diff --git a/src/grt/grt-change_generics.adb b/src/grt/grt-change_generics.adb new file mode 100644 index 0000000..bbec5e4 --- /dev/null +++ b/src/grt/grt-change_generics.adb @@ -0,0 +1,207 @@ +-- GHDL Run Time (GRT) - Override top entity generics +-- Copyright (C) 2015 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +with Grt.Types; use Grt.Types; +with Grt.Lib; use Grt.Lib; +with Grt.Options; use Grt.Options; +with Grt.Avhpi; use Grt.Avhpi; +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; + +package body Grt.Change_Generics is + procedure Error_Override (Msg : String; Over : Generic_Override_Acc) is + begin + Error_C (Msg); + Error_E (" '"); + Error_C (Over.Name.all); + Error_E ("'"); + end Error_Override; + + -- Convert C to E8 values + procedure Ghdl_Value_E8_Char (Res : out Ghdl_E8; + Err : out Boolean; + C : Character; + Rti : Ghdl_Rti_Access) + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Lit_Name : Ghdl_C_String; + begin + for I in 0 .. Enum_Rti.Nbr - 1 loop + Lit_Name := Enum_Rti.Names (I); + if Lit_Name (1) = ''' and Lit_Name (2) = C and Lit_Name (3) = ''' then + Res := Ghdl_E8 (I); + Err := False; + return; + end if; + end loop; + Res := 0; + Err := True; + end Ghdl_Value_E8_Char; + + -- Override for unconstrained array generic. + procedure Override_Generic_Array (Obj_Rti : Ghdl_Rtin_Object_Acc; + Ctxt : Rti_Context; + Over : Generic_Override_Acc) + is + Type_Rti : constant Ghdl_Rtin_Type_Array_Acc := + To_Ghdl_Rtin_Type_Array_Acc (Obj_Rti.Obj_Type); + El_Rti : constant Ghdl_Rti_Access := Type_Rti.Element; + Idx_Rti : constant Ghdl_Rti_Access := Type_Rti.Indexes (0); + Idx_Base_Rti : Ghdl_Rti_Access; + St_Rng, Rng : Ghdl_Range_Ptr; + Arr : Ghdl_E8_Array_Base_Ptr; + Err : Boolean; + Len : Ghdl_Index_Type; + Uc_Array : Ghdl_Uc_Array_Acc; + begin + -- Check array type: + -- - Must be one dimension + if Type_Rti.Nbr_Dim /= 1 then + Error_Override ("multi-dimension array not supported for " + & "override of generic", Over); + return; + end if; + -- - Index must be a scalar integer + if Idx_Rti.Kind /= Ghdl_Rtik_Subtype_Scalar then + Internal_Error ("override_generic_array"); + end if; + Idx_Base_Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Idx_Rti).Basetype; + if Idx_Base_Rti.Kind /= Ghdl_Rtik_Type_I32 then + Error_Override ("non Integer array index not supported for " + & "override of generic", Over); + return; + end if; + -- - Element must be E8 enum. + if El_Rti.Kind /= Ghdl_Rtik_Type_E8 then + Error_Override ("non enumerated element type not supported for " + & "override of generic", Over); + return; + end if; + + -- The real work can start. + St_Rng := To_Ghdl_Range_Ptr + (Loc_To_Addr (Idx_Rti.Depth, + To_Ghdl_Rtin_Subtype_Scalar_Acc (Idx_Rti).Range_Loc, + Ctxt)); + + -- Create the value. + Len := Over.Value'Length; + Arr := To_Ghdl_E8_Array_Base_Ptr (Ghdl_Malloc (Len)); + for I in Over.Value'range loop + Ghdl_Value_E8_Char (Arr (Ghdl_Index_Type (I - Over.Value'First)), Err, + Over.Value (I), El_Rti); + if Err then + Error_Override ("invalid character for override of generic", Over); + return; + end if; + end loop; + + -- Create the range. + Rng := new Ghdl_Range_Type (Mode_I32); + Rng.I32.Left := St_Rng.I32.Left; + Rng.I32.Dir := St_Rng.I32.Dir; + case Rng.I32.Dir is + when Dir_To => + Rng.I32.Right := Rng.I32.Left + Ghdl_I32 (Len - 1); + when Dir_Downto => + Rng.I32.Right := Rng.I32.Left - Ghdl_I32 (Len - 1); + end case; + Rng.I32.Len := Len; + + -- Override the generic. Don't try to free previous value as it may + -- not have been dynamically allocated. + Uc_Array := To_Ghdl_Uc_Array_Acc + (Loc_To_Addr (Obj_Rti.Common.Depth, Obj_Rti.Loc, Ctxt)); + Uc_Array.all := (Base => Arr (0)'Address, + Bounds => Rng.all'Address); + end Override_Generic_Array; + + -- Override DECL with OVER. Dispatch according to generic type. + procedure Override_Generic_Value (Decl : VhpiHandleT; + Over : Generic_Override_Acc) + is + 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); + case Type_Rti.Kind is + when Ghdl_Rtik_Type_Array => + Override_Generic_Array (Obj_Rti, Ctxt, Over); + when others => + Error_Override ("unhandled type for generic override of", Over); + end case; + end Override_Generic_Value; + + -- Handle generic override OVER. Find the generic declaration. + procedure Override_Generic (Over : Generic_Override_Acc) + 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; + if Name_Compare (Decl, Over.Name.all) then + Override_Generic_Value (Decl, Over); + return; + end if; + end loop; + + Error_Override ("cannot find in top entity generic", Over); + end Override_Generic; + + procedure Change_All_Generics + is + Over : Generic_Override_Acc; + begin + -- Handle overrides one by one (in order). + Over := First_Generic_Override; + while Over /= null loop + Override_Generic (Over); + Over := Over.Next; + end loop; + end Change_All_Generics; +end Grt.Change_Generics; diff --git a/src/grt/grt-change_generics.ads b/src/grt/grt-change_generics.ads new file mode 100644 index 0000000..e3439b4 --- /dev/null +++ b/src/grt/grt-change_generics.ads @@ -0,0 +1,29 @@ +-- GHDL Run Time (GRT) - Override top entity generics +-- Copyright (C) 2015 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package Grt.Change_Generics is + -- Override top entity generics, using Generic_Override list from Options. + procedure Change_All_Generics; +end Grt.Change_Generics; diff --git a/src/grt/grt-main.adb b/src/grt/grt-main.adb index 3254777..ad21a24 100644 --- a/src/grt/grt-main.adb +++ b/src/grt/grt-main.adb @@ -35,6 +35,7 @@ with Grt.Hooks; with Grt.Disp_Signals; with Grt.Disp; with Grt.Modules; +with Grt.Change_Generics; -- The following packages are not referenced in this package. -- These are subprograms called only from GHDL generated code. @@ -62,7 +63,7 @@ package body Grt.Main is procedure Ghdl_Init_Top_Generics is begin - null; + Grt.Change_Generics.Change_All_Generics; end Ghdl_Init_Top_Generics; procedure Disp_Stats_Hook (Code : Integer); diff --git a/src/grt/grt-options.adb b/src/grt/grt-options.adb index df1eb4e..f3b9e8c 100644 --- a/src/grt/grt-options.adb +++ b/src/grt/grt-options.adb @@ -470,6 +470,52 @@ package body Grt.Options is Nbr_Threads := Integer (Val); end if; end; + elsif Len > 4 and then Option (1 .. 2) = "-g" then + if Option (3) = '=' then + Error_C ("missing generic name in '"); + Error_C (Option); + Error_E ("'"); + return; + end if; + declare + Eq_Pos : Natural; + Over : Generic_Override_Acc; + Name : String_Access; + begin + if Option (3) = '\' then + -- Extended identifier (not yet handled). + raise Program_Error; + else + -- Search for '='. + Eq_Pos := 0; + for I in 3 .. Option'Last loop + if Option (I) = '=' then + Eq_Pos := I; + exit; + end if; + end loop; + if Eq_Pos = 0 then + Error_C ("missing '=' after generic name in '"); + Error_C (Option); + Error_E ("'"); + end if; + Name := new String (1 .. Eq_Pos - 3); + for I in 3 .. Eq_Pos - 1 loop + Name (I - 2) := To_Lower (Option (I)); + end loop; + end if; + Over := new Generic_Override_Type' + (Name => Name, + Value => new String'(Option (Eq_Pos + 1 .. Option'Last)), + Next => null); + -- Append. + if Last_Generic_Override /= null then + Last_Generic_Override.Next := Over; + else + First_Generic_Override := Over; + end if; + Last_Generic_Override := Over; + end; elsif not Grt.Hooks.Call_Option_Hooks (Option) then Error_C ("unknown option '"); Error_C (Option); diff --git a/src/grt/grt-options.ads b/src/grt/grt-options.ads index 88b1f50..eaf3d02 100644 --- a/src/grt/grt-options.ads +++ b/src/grt/grt-options.ads @@ -147,6 +147,24 @@ package Grt.Options is -- Set the time resolution. -- Only call this subprogram if you are allowed to set the time resolution. procedure Set_Time_Resolution (Res : Character); + + -- Simply linked list of generic override (option -gIDENT=VALUE). + type Generic_Override_Type; + type Generic_Override_Acc is access Generic_Override_Type; + + type Generic_Override_Type is record + -- Name of the generic (lower case). + Name : String_Access; + + -- Value. + Value : String_Access; + + -- Simply linked list. + Next : Generic_Override_Acc; + end record; + + First_Generic_Override : Generic_Override_Acc; + Last_Generic_Override : Generic_Override_Acc; private pragma Export (C, Stack_Size); pragma Export (C, Stack_Max_Size); diff --git a/src/grt/grt-values.adb b/src/grt/grt-values.adb index 3d703bc..2454e17 100644 --- a/src/grt/grt-values.adb +++ b/src/grt/grt-values.adb @@ -61,7 +61,7 @@ package body Grt.Values is -- Convert C to lowercase. function To_LC (C : in Character) return Character is begin - if C >= 'A' and then C <= 'Z' then + if C in 'A' .. 'Z' then return Character'Val (Character'Pos (C) + Character'Pos ('a') - Character'Pos ('A')); else diff --git a/src/grt/grt-vital_annotate.adb b/src/grt/grt-vital_annotate.adb index 3ff0890..1b5ae47 100644 --- a/src/grt/grt-vital_annotate.adb +++ b/src/grt/grt-vital_annotate.adb @@ -28,6 +28,7 @@ with Grt.Astdio; use Grt.Astdio; with Grt.Stdio; use Grt.Stdio; with Grt.Options; with Grt.Avhpi; use Grt.Avhpi; +with Grt.Avhpi_Utils; use Grt.Avhpi_Utils; with Grt.Errors; use Grt.Errors; package body Grt.Vital_Annotate is @@ -40,22 +41,6 @@ package body Grt.Vital_Annotate is Flag_Dump : Boolean := False; Flag_Verbose : constant Boolean := False; - function Name_Compare (Handle : VhpiHandleT; - Name : String; - Property : VhpiStrPropertyT := VhpiNameP) - return Boolean - is - Obj_Name : String (1 .. Name'Length); - Len : Natural; - begin - Vhpi_Get_Str (Property, Handle, Obj_Name, Len); - if Len = Name'Length and then Obj_Name = Name then - return True; - else - return False; - end if; - end Name_Compare; - -- Note: RES may alias CUR. procedure Find_Instance (Cur : VhpiHandleT; Res : out VhpiHandleT; @@ -204,24 +189,8 @@ package body Grt.Vital_Annotate is when VhpiRootInstK => declare Hdl : VhpiHandleT; - Error : AvhpiErrorT; begin - Status := False; - Vhpi_Handle (VhpiDesignUnit, Sdf_Inst, Hdl, Error); - if Error /= AvhpiErrorOk then - Internal_Error ("VhpiDesignUnit"); - return; - end if; - case Vhpi_Get_Kind (Hdl) is - when VhpiArchBodyK => - Vhpi_Handle (VhpiPrimaryUnit, Hdl, Hdl, Error); - if Error /= AvhpiErrorOk then - Internal_Error ("VhpiPrimaryUnit"); - return; - end if; - when others => - Internal_Error ("sdf_instance_end"); - end case; + Hdl := Get_Root_Entity (Sdf_Inst); Status := Name_Compare (Hdl, Context.Celltype (1 .. Context.Celltype_Len)); end; @@ -483,7 +452,6 @@ package body Grt.Vital_Annotate is end if; end Sdf_Generic; - procedure Annotate (Arg : String) is S, E : Natural; diff --git a/testsuite/gna/ticket37/dispgen.vhdl b/testsuite/gna/ticket37/dispgen.vhdl new file mode 100644 index 0000000..73dd486 --- /dev/null +++ b/testsuite/gna/ticket37/dispgen.vhdl @@ -0,0 +1,8 @@ +entity dispgen is + generic (str : string := "init"); +end dispgen; + +architecture behav of dispgen is +begin + assert false report "str: " & str severity note; +end behav; diff --git a/testsuite/gna/ticket37/testsuite.sh b/testsuite/gna/ticket37/testsuite.sh new file mode 100755 index 0000000..ea51e5c --- /dev/null +++ b/testsuite/gna/ticket37/testsuite.sh @@ -0,0 +1,12 @@ +#! /bin/sh + +. ../../testenv.sh + +analyze dispgen.vhdl +elab_simulate dispgen + +elab_simulate dispgen -gstr=Hello + +clean + +echo "Test successful" |