Allow allocators in default value of subprograms

(Handle them in are_trees_equal).

5 files changed, 193 insertions, 49 deletions

diff --git a/src/vhdl/sem.adb b/src/vhdl/sem.adb
index 0d67a19c8..ca340303f 100644
--- a/src/vhdl/sem.adb
+++ b/src/vhdl/sem.adb
@@ -1531,6 +1531,12 @@ package body Sem is
          when Iir_Kind_Character_Literal =>
             return Are_Trees_Equal (Get_Named_Entity (Left),
                                     Get_Named_Entity (Right));
+         when Iir_Kind_Allocator_By_Subtype =>
+            return Are_Trees_Equal (Get_Subtype_Indication (Left),
+                                    Get_Subtype_Indication (Right));
+         when Iir_Kind_Allocator_By_Expression =>
+            return Are_Trees_Equal (Get_Expression (Left),
+                                    Get_Expression (Right));
          when others =>
             Error_Kind ("are_trees_equal", Left);
       end case;
diff --git a/src/vhdl/translate/trans-chap12.adb b/src/vhdl/translate/trans-chap12.adb
index 63661317d..35159e9b9 100644
--- a/src/vhdl/translate/trans-chap12.adb
+++ b/src/vhdl/translate/trans-chap12.adb
@@ -284,6 +284,55 @@ package body Trans.Chap12 is
       Pop_Identifier_Prefix (Lib_Mark);
    end Gen_Dummy_Default_Config;
 
+   procedure Gen_Dummy_Entity_Declaration (Entity : Iir_Entity_Declaration)
+   is
+      Lib : Iir_Library_Declaration;
+      Lib_Mark, Entity_Mark, Arch_Mark : Id_Mark_Type;
+
+      Const : O_Dnode;
+      Instance : O_Dnode;
+      Inter_List : O_Inter_List;
+      Subprg : O_Dnode;
+   begin
+      --  Create trampoline for elab, default_architecture
+      --  re-create instsize.
+      Reset_Identifier_Prefix;
+      Lib := Get_Library (Get_Design_File (Get_Design_Unit (Entity)));
+      Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib));
+      Push_Identifier_Prefix (Entity_Mark, Get_Identifier (Entity));
+      Push_Identifier_Prefix (Arch_Mark, "LASTARCH");
+
+      --  Instance size.
+      New_Const_Decl
+        (Const, Create_Identifier ("INSTSIZE"), O_Storage_Public,
+         Ghdl_Index_Type);
+      Start_Const_Value (Const);
+      Finish_Const_Value (Const, Ghdl_Index_0);
+
+      --  Elaborator.
+      Start_Procedure_Decl
+        (Inter_List, Create_Identifier ("ELAB"), O_Storage_Public);
+      New_Interface_Decl (Inter_List, Instance, Wki_Instance, Ghdl_Ptr_Type);
+      Finish_Subprogram_Decl (Inter_List, Subprg);
+
+      Start_Subprogram_Body (Subprg);
+      Finish_Subprogram_Body;
+
+      --  Default config.
+      Start_Procedure_Decl
+        (Inter_List, Create_Identifier ("DEFAULT_CONFIG"), O_Storage_Public);
+      New_Interface_Decl (Inter_List, Instance, Wki_Instance, Ghdl_Ptr_Type);
+      Finish_Subprogram_Decl (Inter_List, Subprg);
+
+      Start_Subprogram_Body (Subprg);
+      Finish_Subprogram_Body;
+
+      Pop_Identifier_Prefix (Arch_Mark);
+      Pop_Identifier_Prefix (Entity_Mark);
+      Pop_Identifier_Prefix (Lib_Mark);
+   end Gen_Dummy_Entity_Declaration;
+
+   --  Generate dummy subprograms for a package declaration.
    procedure Gen_Dummy_Package_Declaration (Unit : Iir_Design_Unit)
    is
       Pkg : Iir_Package_Declaration;
@@ -350,6 +399,7 @@ package body Trans.Chap12 is
       Pop_Identifier_Prefix (Lib_Mark);
    end Gen_Dummy_Package_Declaration;
 
+   --  Write to file FILELIST all the files that are needed to link the design.
    procedure Write_File_List (Filelist : String)
    is
       use Interfaces.C_Streams;
@@ -394,6 +444,8 @@ package body Trans.Chap12 is
                      Gen_Dummy_Package_Declaration (Unit);
                   end if;
                end;
+            when Iir_Kind_Entity_Declaration =>
+               Gen_Dummy_Entity_Declaration (Lib_Unit);
             when Iir_Kind_Architecture_Body =>
                Gen_Dummy_Default_Config (Lib_Unit);
             when others =>
@@ -422,7 +474,9 @@ package body Trans.Chap12 is
          Unit := Get_First_Design_Unit (File);
          while Unit /= Null_Iir loop
             if not Get_Elab_Flag (Unit) then
-               --  Unit not used.
+               --  Unit is not used for the design, but is present in the final
+               --  link.  As it may import dependencies, generate dummy
+               --  subprograms and variables for these dependencies.
                Add_Unit_Dependences (Unit);
             end if;
             Unit := Get_Chain (Unit);
@@ -466,6 +520,7 @@ package body Trans.Chap12 is
             --  link case failed.
             Add_File_Units (File);
 
+            --  Write '>LIBRARY_DIRECTORY'.
             Lib := Get_Library (File);
             R := fputc (Character'Pos ('>'), F);
             Id := Get_Library_Directory (Lib);
@@ -473,6 +528,7 @@ package body Trans.Chap12 is
                          size_t (Get_Name_Length (Id)), 1, F);
             R := fputc (10, F);
 
+            --  Write 'FILENAME'.
             Id := Get_Design_File_Filename (File);
             S := fwrite (Get_Address (Id),
                          size_t (Get_Name_Length (Id)), 1, F);
diff --git a/src/vhdl/translate/trans-chap8.adb b/src/vhdl/translate/trans-chap8.adb
index ca05eb67a..e291efede 100644
--- a/src/vhdl/translate/trans-chap8.adb
+++ b/src/vhdl/translate/trans-chap8.adb
@@ -29,6 +29,7 @@ with Trans.Chap3;
 with Trans.Chap4;
 with Trans.Chap6;
 with Trans.Chap7;
+with Trans.Chap9;
 with Trans.Chap14;
 with Trans_Decls; use Trans_Decls;
 with Translation; use Translation;
@@ -1978,6 +1979,12 @@ package body Trans.Chap8 is
                New_Association (Constr, Val);
             end if;
          end if;
+
+         if Get_Kind (El) = Iir_Kind_Association_Element_Open then
+            --  Do not share nodes for default values: clean them.
+            Chap9.Destroy_Types (Get_Default_Value (Base_Formal));
+         end if;
+
          El := Get_Chain (El);
          Pos := Pos + 1;
       end loop;
diff --git a/src/vhdl/translate/trans-chap9.adb b/src/vhdl/translate/trans-chap9.adb
index 9a7bf98f9..e17dc2ea1 100644
--- a/src/vhdl/translate/trans-chap9.adb
+++ b/src/vhdl/translate/trans-chap9.adb
@@ -24,6 +24,7 @@ with Libraries;
 with Canon;
 with Canon_PSL;
 with Trans_Analyzes;
+with Nodes_Meta;
 with PSL.Nodes;
 with PSL.NFAs;
 with PSL.NFAs.Utils;
@@ -993,63 +994,130 @@ package body Trans.Chap9 is
    --  If the type is referenced again, the variables must be reachable.
    --  This is not the case for elaborator subprogram (which may references
    --  slices in the sensitivity or driver list) and the process subprg.
-   procedure Destroy_Types_In_Name (Name : Iir)
+   procedure Destroy_Types_In_Chain (Chain : Iir)
    is
-      El    : Iir;
-      Atype : Iir;
-      Info  : Type_Info_Acc;
+      N : Iir;
    begin
-      El := Name;
-      loop
-         Atype := Null_Iir;
-         case Get_Kind (El) is
-            when Iir_Kind_Selected_Element
-               | Iir_Kind_Indexed_Name =>
-               El := Get_Prefix (El);
-            when Iir_Kind_Slice_Name =>
-               Atype := Get_Type (El);
-               El := Get_Prefix (El);
-            when Iir_Kind_Object_Alias_Declaration =>
-               El := Get_Name (El);
-            when Iir_Kind_Stable_Attribute
-               | Iir_Kind_Quiet_Attribute
-               | Iir_Kind_Delayed_Attribute
-               | Iir_Kind_Transaction_Attribute =>
-               El := Get_Prefix (El);
-            when Iir_Kind_Signal_Declaration
-               | Iir_Kind_Interface_Signal_Declaration
-               | Iir_Kind_Guard_Signal_Declaration =>
-               exit;
-            when Iir_Kinds_Denoting_Name =>
-               El := Get_Named_Entity (El);
-            when others =>
-               Error_Kind ("destroy_types_in_name", El);
-         end case;
-         if Atype /= Null_Iir
-           and then Is_Anonymous_Type_Definition (Atype)
-         then
-            Info := Get_Info (Atype);
-            if Info /= null then
-               Free_Type_Info (Info);
-               Clear_Info (Atype);
-            end if;
-         end if;
+      N := Chain;
+      while N /= Null_Iir loop
+         Destroy_Types (N);
+         N := Get_Chain (N);
       end loop;
-   end Destroy_Types_In_Name;
+   end Destroy_Types_In_Chain;
 
-   procedure Destroy_Types_In_List (List : Iir_List)
+   procedure Destroy_Types_In_List (L : Iir_List)
    is
       El : Iir;
    begin
-      if List = Null_Iir_List then
+      case L is
+         when Null_Iir_List
+            | Iir_List_All
+            | Iir_List_Others =>
+            return;
+         when others =>
+            for I in Natural loop
+               El := Get_Nth_Element (L, I);
+               exit when El = Null_Iir;
+               Destroy_Types (El);
+            end loop;
+      end case;
+   end Destroy_Types_In_List;
+
+   procedure Destroy_Types (N : Iir) is
+   begin
+      --  Nothing to do for null node.
+      if N = Null_Iir then
          return;
       end if;
-      for I in Natural loop
-         El := Get_Nth_Element (List, I);
-         exit when El = Null_Iir;
-         Destroy_Types_In_Name (El);
-      end loop;
-   end Destroy_Types_In_List;
+
+      declare
+         use Nodes_Meta;
+         Kind      : constant Iir_Kind := Get_Kind (N);
+         Fields    : constant Fields_Array := Get_Fields (Kind);
+         F         : Fields_Enum;
+      begin
+         for I in Fields'Range loop
+            F := Fields (I);
+            case F is
+               when Field_Literal_Subtype
+                 | Field_Slice_Subtype =>
+                  declare
+                     T : constant Iir := Get_Iir (N, F);
+                     Info : Type_Info_Acc;
+                  begin
+                     Info := Get_Info (T);
+                     if Info /= null then
+                        Free_Type_Info (Info);
+                        Clear_Info (T);
+                     end if;
+                  end;
+               when others =>
+                  null;
+            end case;
+
+            case Get_Field_Type (F) is
+               when Type_Iir =>
+                  case Get_Field_Attribute (F) is
+                     when Attr_None =>
+                        Destroy_Types (Get_Iir (N, F));
+                     when Attr_Ref =>
+                        null;
+                     when Attr_Maybe_Ref =>
+                        if not Get_Is_Ref (N) then
+                           Destroy_Types (Get_Iir (N, F));
+                        end if;
+                     when Attr_Chain =>
+                        Destroy_Types_In_Chain (Get_Iir (N, F));
+                     when Attr_Chain_Next =>
+                        null;
+                     when Attr_Of_Ref =>
+                        raise Internal_Error;
+                  end case;
+               when Type_Iir_List =>
+                  case Get_Field_Attribute (F) is
+                     when Attr_None =>
+                        Destroy_Types_In_List (Get_Iir_List (N, F));
+                     when Attr_Ref
+                        | Attr_Of_Ref =>
+                        null;
+                     when others =>
+                        raise Internal_Error;
+                  end case;
+               when Type_PSL_NFA
+                  | Type_PSL_Node =>
+                  --  TODO
+                  raise Internal_Error;
+               when Type_Date_Type
+                 | Type_Date_State_Type
+                 | Type_Time_Stamp_Id
+                 | Type_File_Checksum_Id
+                 | Type_String8_Id
+                 | Type_Source_Ptr
+                 | Type_Base_Type
+                 | Type_Iir_Constraint
+                 | Type_Iir_Mode
+                 | Type_Iir_Index32
+                 | Type_Iir_Int64
+                 | Type_Boolean
+                 | Type_Iir_Staticness
+                 | Type_Iir_All_Sensitized
+                 | Type_Iir_Signal_Kind
+                 | Type_Tri_State_Type
+                 | Type_Iir_Pure_State
+                 | Type_Iir_Delay_Mechanism
+                 | Type_Iir_Predefined_Functions
+                 | Type_Iir_Direction
+                 | Type_Location_Type
+                 | Type_Iir_Int32
+                 | Type_Int32
+                 | Type_Iir_Fp64
+                 | Type_Token_Type
+                 | Type_Name_Id =>
+                  null;
+            end case;
+         end loop;
+      end;
+   end Destroy_Types;
 
    procedure Gen_Register_Direct_Driver_Non_Composite
      (Targ : Mnode; Targ_Type : Iir; Drv : Mnode)
diff --git a/src/vhdl/translate/trans-chap9.ads b/src/vhdl/translate/trans-chap9.ads
index 51d059090..748911b69 100644
--- a/src/vhdl/translate/trans-chap9.ads
+++ b/src/vhdl/translate/trans-chap9.ads
@@ -30,5 +30,12 @@ package Trans.Chap9 is
    procedure Translate_Entity_Instantiation
      (Aspect : Iir; Mapping : Iir; Parent : Iir; Config_Override : Iir);
 
+   --  Remove anonymous and implicit type definitions in a list of names.
+   --  Such type definitions are created during slice translations, however
+   --  variables created are defined in the translation scope.
+   --  If the type is referenced again, the variables must be reachable.
+   --  This is not the case for elaborator subprogram (which may references
+   --  slices in the sensitivity or driver list) and the process subprg.
+   procedure Destroy_Types (N : Iir);
 end Trans.Chap9;