Implement ticket 37: add switch -gNAME=VAL to override top entity generics.

12 files changed, 430 insertions, 37 deletions

diff --git a/src/grt/grt-avhpi.adb b/src/grt/grt-avhpi.adb
index af2dc1b05..535cb0ad3 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 000000000..6fedf1b4c
--- /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 000000000..d16b9c2d3
--- /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 000000000..bbec5e47f
--- /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 000000000..e3439b47b
--- /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 32547774b..ad21a245a 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 df1eb4ec8..f3b9e8cdb 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 88b1f5084..eaf3d022d 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 3d703bc85..2454e175e 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 3ff089087..1b5ae471a 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 000000000..73dd48619
--- /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 000000000..ea51e5c79
--- /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"