1 files changed, 207 insertions, 0 deletions
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;