vhdl: handle -gGEN=VAL for --synth. Fix #1062

6 files changed, 213 insertions, 23 deletions

diff --git a/src/ghdldrv/ghdllocal.adb b/src/ghdldrv/ghdllocal.adb
index 08307d7eb..79a6d0006 100644
--- a/src/ghdldrv/ghdllocal.adb
+++ b/src/ghdldrv/ghdllocal.adb
@@ -56,6 +56,68 @@ package body Ghdllocal is
       Compile_Init;
    end Init;
 
+   function Is_Generic_Override_Option (Opt : String) return Boolean
+   is
+      pragma Assert (Opt'First = 1);
+   begin
+      if Opt (1 .. 2) /= "-g" then
+         return False;
+      end if;
+      --  Look for '='.
+      for I in 3 .. Opt'Last loop
+         if Opt (I) = '=' then
+            --  Ideally, OPT must be of the form -gGEN=VAL, where GEN is
+            --  a generic name, and VAL a literal.
+            return True;
+         end if;
+      end loop;
+      return False;
+   end Is_Generic_Override_Option;
+
+   function Decode_Generic_Override_Option (Opt : String) return Option_State
+   is
+      use Errorout;
+      pragma Assert (Opt'First = 1);
+      pragma Assert (Opt'Last >= 5);
+      Eq_Pos : Natural;
+      Id : Name_Id;
+   begin
+      Eq_Pos := 0;
+      for I in 3 .. Opt'Last loop
+         if Opt (I) = '=' then
+            Eq_Pos := I;
+            exit;
+         end if;
+      end loop;
+      if Eq_Pos = 0 then
+         Error_Msg_Option ("missing '=' in generic override option");
+         return Option_Err;
+      elsif Eq_Pos < 3 then
+         Error_Msg_Option ("missing generic name in generic override option");
+         return Option_Err;
+      elsif Eq_Pos = Opt'Last then
+         Error_Msg_Option ("missing value in generic override option");
+         return Option_Err;
+      end if;
+
+      declare
+         Res : String (1 .. Eq_Pos - 3) := Opt (3 .. Eq_Pos - 1);
+         Err : Boolean;
+      begin
+         Vhdl.Scanner.Convert_Identifier (Res, Err);
+         if Err then
+            Error_Msg_Option
+              ("incorrect generic name in generic override option");
+            return Option_Err;
+         end if;
+         Id := Name_Table.Get_Identifier (Res);
+      end;
+
+      Vhdl.Configuration.Add_Generic_Override
+        (Id, Opt (Eq_Pos + 1 .. Opt'Last));
+      return Option_Ok;
+   end Decode_Generic_Override_Option;
+
    function Decode_Driver_Option (Opt : String) return Option_State
    is
       pragma Assert (Opt'First = 1);
@@ -74,10 +136,13 @@ package body Ghdllocal is
          Flag_Ieee := Lib_Standard;
       elsif Opt = "-m32" then
          Flag_32bit := True;
-      elsif Opt'Length >= 2
-        and then (Opt (2) = 'g' or Opt (2) = 'O')
+      elsif Opt'Length >= 2 and then Opt (2) = 'O' then
+         --  Silently accept -O
+         null;
+      elsif Opt'Length >= 2 and then Opt (2) = 'g'
+        and then not Is_Generic_Override_Option (Opt)
       then
-         --  Silently accept -g and -O.
+         --  Silently accept -g (if this is not a generic override option).
          null;
       else
          return Options.Parse_Option (Opt);
diff --git a/src/ghdldrv/ghdllocal.ads b/src/ghdldrv/ghdllocal.ads
index ffaceabf9..042c51d87 100644
--- a/src/ghdldrv/ghdllocal.ads
+++ b/src/ghdldrv/ghdllocal.ads
@@ -148,5 +148,13 @@ package Ghdllocal is
                                 Prim_Id : out Name_Id;
                                 Sec_Id : out Name_Id);
 
+   --  Report true iff OPT has the form '-gGEN=VAL'.  Used to distingish from
+   --  debugging (like '-g' or '-ggdb' or '-g2') options.
+   function Is_Generic_Override_Option (Opt : String) return Boolean;
+
+   --  Handle generic override option OPT.  Return Option_Err if the generic
+   --  name is incorrect.
+   function Decode_Generic_Override_Option (Opt : String) return Option_State;
+
    procedure Register_Commands;
 end Ghdllocal;
diff --git a/src/ghdldrv/ghdlsynth.adb b/src/ghdldrv/ghdlsynth.adb
index 31ab180ab..c87405ca3 100644
--- a/src/ghdldrv/ghdlsynth.adb
+++ b/src/ghdldrv/ghdlsynth.adb
@@ -87,9 +87,16 @@ package body Ghdlsynth is
    procedure Decode_Option (Cmd : in out Command_Synth;
                             Option : String;
                             Arg : String;
-                            Res : out Option_State) is
+                            Res : out Option_State)
+   is
+      pragma Assert (Option'First = 1);
    begin
-      if Option = "--disp-noinline" then
+      if Option'Last > 3
+        and then Option (2) = 'g'
+        and then Is_Generic_Override_Option (Option)
+      then
+         Res := Decode_Generic_Override_Option (Option);
+      elsif Option = "--disp-noinline" then
          Cmd.Disp_Inline := False;
          Res := Option_Ok;
       elsif Option = "--disp-noid" then
@@ -237,6 +244,7 @@ package body Ghdlsynth is
          Entity : constant Iir :=
            Vhdl.Utils.Get_Entity_From_Configuration (Config);
       begin
+         Vhdl.Configuration.Apply_Generic_Override (Entity);
          Vhdl.Configuration.Check_Entity_Declaration_Top (Entity, False);
          if Nbr_Errors > 0 then
             return Null_Iir;
diff --git a/src/vhdl/vhdl-configuration.adb b/src/vhdl/vhdl-configuration.adb
index 07a98400c..dcb2d2f59 100644
--- a/src/vhdl/vhdl-configuration.adb
+++ b/src/vhdl/vhdl-configuration.adb
@@ -16,17 +16,19 @@
 --  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 --  02111-1307, USA.
 
-with Libraries;
+with Name_Table; use Name_Table;
+with Str_Table;
+with Flags;
 with Errorout; use Errorout;
+with Libraries;
 with Vhdl.Errors; use Vhdl.Errors;
 with Vhdl.Std_Package;
-with Name_Table; use Name_Table;
-with Flags;
 with Vhdl.Utils; use Vhdl.Utils;
 with Vhdl.Nodes_Walk;
 with Vhdl.Sem_Scopes;
 with Vhdl.Sem_Lib; use Vhdl.Sem_Lib;
 with Vhdl.Canon;
+with Vhdl.Evaluation;
 
 package body Vhdl.Configuration is
    procedure Add_Design_Concurrent_Stmts (Parent : Iir);
@@ -1032,4 +1034,106 @@ package body Vhdl.Configuration is
       end if;
    end Find_Top_Entity;
 
+   type Override_Entry is record
+      Gen : Name_Id;
+      Value : String_Acc;
+   end record;
+
+   package Override_Table is new Tables
+     (Table_Component_Type => Override_Entry,
+      Table_Index_Type => Natural,
+      Table_Low_Bound => 1,
+      Table_Initial => 16);
+
+   procedure Add_Generic_Override (Id : Name_Id; Value : String) is
+   begin
+      Override_Table.Append (Override_Entry'(Gen => Id,
+                                             Value => new String'(Value)));
+   end Add_Generic_Override;
+
+   procedure Override_Generic (Gen : Iir; Value : String_Acc)
+   is
+      use Vhdl.Evaluation;
+      Formal_Type : constant Iir := Get_Type (Gen);
+      Formal_Btype : constant Iir := Get_Base_Type (Formal_Type);
+      Res : Iir;
+   begin
+      case Get_Kind (Formal_Btype) is
+         when Iir_Kind_Integer_Type_Definition
+           | Iir_Kind_Enumeration_Type_Definition =>
+            Res := Eval_Value_Attribute (Value.all, Formal_Type, Gen);
+            if not Eval_Is_In_Bound (Res, Formal_Type) then
+               Error_Msg_Elab ("override for %n is out of bounds", +Gen);
+               return;
+            end if;
+            Set_Literal_Origin (Res, Null_Iir);
+         when Iir_Kind_Array_Type_Definition =>
+            if Is_One_Dimensional_Array_Type (Formal_Btype) then
+               declare
+                  use Str_Table;
+                  Str8 : String8_Id;
+                  Ntype : Iir;
+               begin
+                  Str8 := Create_String8;
+                  Append_String8_String (Value.all);
+                  Res := Create_Iir (Iir_Kind_String_Literal8);
+                  Set_String8_Id (Res, Str8);
+                  --  FIXME: check characters are in the type.
+                  Set_String_Length (Res, Value'Length);
+                  Set_Expr_Staticness (Res, Locally);
+                  Ntype := Create_Unidim_Array_By_Length
+                    (Get_Base_Type (Formal_Type), Value'Length, Res);
+                  Set_Type (Res, Ntype);
+                  Set_Literal_Subtype (Res, Ntype);
+               end;
+            else
+               Res := Null_Iir;
+            end if;
+         when others =>
+            Res := Null_Iir;
+      end case;
+      if Res = Null_Iir then
+         Error_Msg_Elab ("unhandled override for %n", +Gen);
+      end if;
+
+      if Get_Is_Ref (Gen) then
+         Set_Is_Ref (Gen, False);
+      else
+         if Get_Has_Identifier_List (Gen) then
+            --  Transfer ownership to the next interface.
+            Set_Is_Ref (Get_Chain (Gen), False);
+         end if;
+      end if;
+      Set_Location (Res, No_Location);
+      Set_Default_Value (Gen, Res);
+   end Override_Generic;
+
+   procedure Apply_Generic_Override (Ent : Iir)
+   is
+      Inter_Chain : constant Iir := Get_Generic_Chain (Ent);
+      Inter : Iir;
+   begin
+      for I in Override_Table.First .. Override_Table.Last loop
+         declare
+            Over : constant Override_Entry := Override_Table.Table (I);
+         begin
+            Inter := Inter_Chain;
+            while Inter /= Null_Iir loop
+               exit when Get_Identifier (Inter) = Over.Gen;
+               Inter := Get_Chain (Inter);
+            end loop;
+
+            if Inter = Null_Iir then
+               Error_Msg_Elab ("no generic %i for -g", +Over.Gen);
+            elsif Get_Kind (Inter) /= Iir_Kind_Interface_Constant_Declaration
+            then
+               Error_Msg_Elab
+                 ("generic %n cannot be overriden (not a constant)",
+                  +Over.Gen);
+            else
+               Override_Generic (Inter, Over.Value);
+            end if;
+         end;
+      end loop;
+   end Apply_Generic_Override;
 end Vhdl.Configuration;
diff --git a/src/vhdl/vhdl-configuration.ads b/src/vhdl/vhdl-configuration.ads
index c9f1d1194..f31750a1d 100644
--- a/src/vhdl/vhdl-configuration.ads
+++ b/src/vhdl/vhdl-configuration.ads
@@ -61,4 +61,10 @@ package Vhdl.Configuration is
    --  a design file): mark all instantiated units and return the unmarked
    --  one if there is only one.
    function Find_Top_Entity (From : Iir) return Iir;
+
+   --  Add an override for generic ID.
+   procedure Add_Generic_Override (Id : Name_Id; Value : String);
+
+   --  Apply generic overrides to entity ENT.
+   procedure Apply_Generic_Override (Ent : Iir);
 end Vhdl.Configuration;
diff --git a/src/vhdl/vhdl-scanner.adb b/src/vhdl/vhdl-scanner.adb
index aadb0d538..55a98e03f 100644
--- a/src/vhdl/vhdl-scanner.adb
+++ b/src/vhdl/vhdl-scanner.adb
@@ -1537,6 +1537,7 @@ package body Vhdl.Scanner is
 
    procedure Convert_Identifier (Str : in out String; Err : out Boolean)
    is
+      pragma Assert (Str'First = 1);
       procedure Error_Bad is
       begin
          Error_Msg_Option ("bad character in identifier");
@@ -1548,41 +1549,39 @@ package body Vhdl.Scanner is
       end Error_8bit;
 
       C : Character;
-      subtype Id_Subtype is String (1 .. Str'Length);
-      Id : Id_Subtype renames Str;
    begin
       Err := True;
 
-      if Id'Length = 0 then
+      if Str'Length = 0 then
          Error_Msg_Option ("identifier required");
          return;
       end if;
 
-      if Id (1) = '\' then
+      if Str (1) = '\' then
          --  Extended identifier.
          if Vhdl_Std = Vhdl_87 then
             Error_Msg_Option ("extended identifiers not allowed in vhdl87");
             return;
          end if;
 
-         if Id'Length < 3 then
+         if Str'Length < 3 then
             Error_Msg_Option ("extended identifier is too short");
             return;
          end if;
-         if Id (Id'Last) /= '\' then
+         if Str (Str'Last) /= '\' then
             Error_Msg_Option ("extended identifier must finish with a '\'");
             return;
          end if;
-         for I in 2 .. Id'Last - 1 loop
-            C := Id (I);
+         for I in 2 .. Str'Last - 1 loop
+            C := Str (I);
             case Characters_Kind (C) is
                when Format_Effector =>
                   Error_Msg_Option ("format effector in extended identifier");
                   return;
                when Graphic_Character =>
                   if C = '\' then
-                     if Id (I + 1) /= '\'
-                       or else I = Id'Last - 1
+                     if Str (I + 1) /= '\'
+                       or else I = Str'Last - 1
                      then
                         Error_Msg_Option ("anti-slash must be doubled "
                                             & "in extended identifier");
@@ -1596,15 +1595,15 @@ package body Vhdl.Scanner is
          end loop;
       else
          --  Identifier
-         for I in 1 .. Id'Length loop
-            C := Id (I);
+         for I in 1 .. Str'Length loop
+            C := Str (I);
             case Characters_Kind (C) is
                when Upper_Case_Letter =>
                   if Vhdl_Std = Vhdl_87 and C > 'Z' then
                      Error_8bit;
                      return;
                   end if;
-                  Id (I) := To_Lower_Map (C);
+                  Str (I) := To_Lower_Map (C);
                when Lower_Case_Letter | Digit =>
                   if Vhdl_Std = Vhdl_87 and C > 'z' then
                      Error_8bit;
@@ -1618,12 +1617,12 @@ package body Vhdl.Scanner is
                           ("an identifier cannot start with an underscore");
                         return;
                      end if;
-                     if Id (I - 1) = '_' then
+                     if Str (I - 1) = '_' then
                         Error_Msg_Option
                           ("two underscores can't be consecutive");
                         return;
                      end if;
-                     if I = Id'Last then
+                     if I = Str'Last then
                         Error_Msg_Option
                           ("an identifier cannot finish with an underscore");
                         return;