vhdl08: first working example of interface type.

8 files changed, 152 insertions, 15 deletions

diff --git a/src/vhdl/iirs.adb b/src/vhdl/iirs.adb
index 01d6bfeac..1cf90d515 100644
--- a/src/vhdl/iirs.adb
+++ b/src/vhdl/iirs.adb
@@ -4530,6 +4530,22 @@ package body Iirs is
       Set_Field4 (Target, Chain);
    end Set_Individual_Association_Chain;
 
+   function Get_Subprogram_Association_Chain (Target : Iir) return Iir is
+   begin
+      pragma Assert (Target /= Null_Iir);
+      pragma Assert (Has_Subprogram_Association_Chain (Get_Kind (Target)),
+                     "no field Subprogram_Association_Chain");
+      return Get_Field4 (Target);
+   end Get_Subprogram_Association_Chain;
+
+   procedure Set_Subprogram_Association_Chain (Target : Iir; Chain : Iir) is
+   begin
+      pragma Assert (Target /= Null_Iir);
+      pragma Assert (Has_Subprogram_Association_Chain (Get_Kind (Target)),
+                     "no field Subprogram_Association_Chain");
+      Set_Field4 (Target, Chain);
+   end Set_Subprogram_Association_Chain;
+
    function Get_Aggregate_Info (Target : Iir) return Iir is
    begin
       pragma Assert (Target /= Null_Iir);
diff --git a/src/vhdl/iirs.ads b/src/vhdl/iirs.ads
index bbafdd816..8b3904e3a 100644
--- a/src/vhdl/iirs.ads
+++ b/src/vhdl/iirs.ads
@@ -413,8 +413,10 @@ package Iirs is
    -- Only for Iir_Kind_Association_Element_By_Expression:
    --   Get/Set_In_Conversion (Field4)
    --
-   -- Only for Iir_Kind_Association_Element_By_Individual:
    -- Only for Iir_Kind_Association_Element_Type:
+   --   Get/Set_Subprogram_Association_Chain (Field4)
+   --
+   -- Only for Iir_Kind_Association_Element_By_Individual:
    --   Get/Set_Actual_Type (Field5)
    --
    -- Only for Iir_Kind_Association_Element_By_Expression:
@@ -5877,7 +5879,7 @@ package Iirs is
    procedure Set_Subtype_Definition (Target : Iir; Def : Iir);
 
    --  Implicit operations of an interface type declaration.
-   --  Field: Field4
+   --  Field: Field4 Chain
    function Get_Interface_Type_Subprograms (Target : Iir) return Iir;
    procedure Set_Interface_Type_Subprograms (Target : Iir; Subprg : Iir);
 
@@ -6700,6 +6702,11 @@ package Iirs is
    function Get_Individual_Association_Chain (Target : Iir) return Iir;
    procedure Set_Individual_Association_Chain (Target : Iir; Chain : Iir);
 
+   --  Chain of implicit subprogram associations for a type association.
+   --  Field: Field4 Chain
+   function Get_Subprogram_Association_Chain (Target : Iir) return Iir;
+   procedure Set_Subprogram_Association_Chain (Target : Iir; Chain : Iir);
+
    --  Get/Set info for the aggregate.
    --  There is one aggregate_info for for each dimension.
    --  Field: Field2
diff --git a/src/vhdl/nodes_meta.adb b/src/vhdl/nodes_meta.adb
index da825a1f1..7bfbc7364 100644
--- a/src/vhdl/nodes_meta.adb
+++ b/src/vhdl/nodes_meta.adb
@@ -268,6 +268,7 @@ package body Nodes_Meta is
       Field_Actual_Type => Type_Iir,
       Field_Association_Chain => Type_Iir,
       Field_Individual_Association_Chain => Type_Iir,
+      Field_Subprogram_Association_Chain => Type_Iir,
       Field_Aggregate_Info => Type_Iir,
       Field_Sub_Aggregate_Info => Type_Iir,
       Field_Aggr_Dynamic_Flag => Type_Boolean,
@@ -836,6 +837,8 @@ package body Nodes_Meta is
             return "association_chain";
          when Field_Individual_Association_Chain =>
             return "individual_association_chain";
+         when Field_Subprogram_Association_Chain =>
+            return "subprogram_association_chain";
          when Field_Aggregate_Info =>
             return "aggregate_info";
          when Field_Sub_Aggregate_Info =>
@@ -1669,7 +1672,7 @@ package body Nodes_Meta is
          when Field_Subtype_Definition =>
             return Attr_None;
          when Field_Interface_Type_Subprograms =>
-            return Attr_None;
+            return Attr_Chain;
          when Field_Nature =>
             return Attr_None;
          when Field_Mode =>
@@ -1990,6 +1993,8 @@ package body Nodes_Meta is
             return Attr_Chain;
          when Field_Individual_Association_Chain =>
             return Attr_Chain;
+         when Field_Subprogram_Association_Chain =>
+            return Attr_Chain;
          when Field_Aggregate_Info =>
             return Attr_None;
          when Field_Sub_Aggregate_Info =>
@@ -2262,7 +2267,7 @@ package body Nodes_Meta is
       Field_Formal,
       Field_Chain,
       Field_Actual,
-      Field_Actual_Type,
+      Field_Subprogram_Association_Chain,
       --  Iir_Kind_Association_Element_Subprogram
       Field_Whole_Association_Flag,
       Field_Collapse_Signal_Flag,
@@ -5137,6 +5142,8 @@ package body Nodes_Meta is
             return Get_Association_Chain (N);
          when Field_Individual_Association_Chain =>
             return Get_Individual_Association_Chain (N);
+         when Field_Subprogram_Association_Chain =>
+            return Get_Subprogram_Association_Chain (N);
          when Field_Aggregate_Info =>
             return Get_Aggregate_Info (N);
          when Field_Sub_Aggregate_Info =>
@@ -5511,6 +5518,8 @@ package body Nodes_Meta is
             Set_Association_Chain (N, V);
          when Field_Individual_Association_Chain =>
             Set_Individual_Association_Chain (N, V);
+         when Field_Subprogram_Association_Chain =>
+            Set_Subprogram_Association_Chain (N, V);
          when Field_Aggregate_Info =>
             Set_Aggregate_Info (N, V);
          when Field_Sub_Aggregate_Info =>
@@ -9490,13 +9499,7 @@ package body Nodes_Meta is
 
    function Has_Actual_Type (K : Iir_Kind) return Boolean is
    begin
-      case K is
-         when Iir_Kind_Association_Element_By_Individual
-           | Iir_Kind_Association_Element_Type =>
-            return True;
-         when others =>
-            return False;
-      end case;
+      return K = Iir_Kind_Association_Element_By_Individual;
    end Has_Actual_Type;
 
    function Has_Association_Chain (K : Iir_Kind) return Boolean is
@@ -9509,6 +9512,11 @@ package body Nodes_Meta is
       return K = Iir_Kind_Association_Element_By_Individual;
    end Has_Individual_Association_Chain;
 
+   function Has_Subprogram_Association_Chain (K : Iir_Kind) return Boolean is
+   begin
+      return K = Iir_Kind_Association_Element_Type;
+   end Has_Subprogram_Association_Chain;
+
    function Has_Aggregate_Info (K : Iir_Kind) return Boolean is
    begin
       return K = Iir_Kind_Aggregate;
diff --git a/src/vhdl/nodes_meta.ads b/src/vhdl/nodes_meta.ads
index 867a96c23..c9fe6e695 100644
--- a/src/vhdl/nodes_meta.ads
+++ b/src/vhdl/nodes_meta.ads
@@ -308,6 +308,7 @@ package Nodes_Meta is
       Field_Actual_Type,
       Field_Association_Chain,
       Field_Individual_Association_Chain,
+      Field_Subprogram_Association_Chain,
       Field_Aggregate_Info,
       Field_Sub_Aggregate_Info,
       Field_Aggr_Dynamic_Flag,
@@ -806,6 +807,7 @@ package Nodes_Meta is
    function Has_Actual_Type (K : Iir_Kind) return Boolean;
    function Has_Association_Chain (K : Iir_Kind) return Boolean;
    function Has_Individual_Association_Chain (K : Iir_Kind) return Boolean;
+   function Has_Subprogram_Association_Chain (K : Iir_Kind) return Boolean;
    function Has_Aggregate_Info (K : Iir_Kind) return Boolean;
    function Has_Sub_Aggregate_Info (K : Iir_Kind) return Boolean;
    function Has_Aggr_Dynamic_Flag (K : Iir_Kind) return Boolean;
diff --git a/src/vhdl/sem_assocs.adb b/src/vhdl/sem_assocs.adb
index f5dc048b9..3ae609ac1 100644
--- a/src/vhdl/sem_assocs.adb
+++ b/src/vhdl/sem_assocs.adb
@@ -20,8 +20,11 @@ with Errorout; use Errorout;
 with Flags; use Flags;
 with Types; use Types;
 with Iirs_Utils; use Iirs_Utils;
+with Std_Names;
 with Sem_Names; use Sem_Names;
 with Sem_Types;
+with Std_Package;
+with Sem_Scopes;
 with Iir_Chains; use Iir_Chains;
 with Xrefs;
 
@@ -1444,6 +1447,70 @@ package body Sem_Assocs is
       return;
    end Sem_Association_Package;
 
+   --  Create an implicit association_element_subprogram for the declaration
+   --  of function ID for ACTUAL (a name of a type).
+   function Sem_Implicit_Operator_Association
+     (Id : Name_Id; Actual : Iir) return Iir
+   is
+      use Sem_Scopes;
+
+      Atype : constant Iir := Get_Type (Actual);
+
+      --  Return TRUE if DECL is a function declaration with a comparaison
+      --  operator profile.
+      function Has_Comparaison_Profile (Decl : Iir) return Boolean
+      is
+         Inter : Iir;
+      begin
+         --  A function declaration.
+         if Get_Kind (Decl) /= Iir_Kind_Function_Declaration then
+            return False;
+         end if;
+         --  That returns a boolean.
+         if (Get_Base_Type (Get_Return_Type (Decl))
+               /= Std_Package.Boolean_Type_Definition)
+         then
+            return False;
+         end if;
+
+         --  With 2 interfaces of type ATYPE.
+         Inter := Get_Interface_Declaration_Chain (Decl);
+         for I in 1 .. 2 loop
+            if Inter = Null_Iir then
+               return False;
+            end if;
+            if Get_Base_Type (Get_Type (Inter)) /= Get_Base_Type (Atype) then
+               return False;
+            end if;
+            Inter := Get_Chain (Inter);
+         end loop;
+         if Inter /= Null_Iir then
+            return False;
+         end if;
+         return True;
+      end Has_Comparaison_Profile;
+
+      Interp : Name_Interpretation_Type;
+      Decl : Iir;
+      Res : Iir;
+   begin
+      Interp := Get_Interpretation (Id);
+      while Valid_Interpretation (Interp) loop
+         Decl := Get_Declaration (Interp);
+         if Has_Comparaison_Profile (Decl) then
+            Res := Create_Iir (Iir_Kind_Association_Element_Subprogram);
+            Location_Copy (Res, Actual);
+            Set_Actual (Res, Build_Simple_Name (Decl, Get_Location (Actual)));
+            return Res;
+         end if;
+         Interp := Get_Next_Interpretation (Interp);
+      end loop;
+
+      Error_Msg_Sem (+Actual, "cannot find a %i declaration for type %i",
+                     (+Id, +Actual));
+      return Null_Iir;
+   end Sem_Implicit_Operator_Association;
+
    procedure Sem_Association_Type
      (Assoc : Iir;
       Inter : Iir;
@@ -1451,6 +1518,7 @@ package body Sem_Assocs is
       Match : out Compatibility_Level)
    is
       Actual : Iir;
+      Op_Eq, Op_Neq : Iir;
    begin
       if not Finish then
          Sem_Association_Package_Type_Not_Finish (Assoc, Inter, Match);
@@ -1466,7 +1534,18 @@ package body Sem_Assocs is
       --  indication.
       --  FIXME: ghdl only supports type_mark!
       Actual := Sem_Types.Sem_Subtype_Indication (Actual);
-      Set_Actual_Type (Assoc, Get_Type (Actual));
+      Set_Actual (Assoc, Actual);
+
+      --  FIXME: it is not clear at all from the LRM how the implicit
+      --  associations are done...
+      Op_Eq := Sem_Implicit_Operator_Association
+        (Std_Names.Name_Op_Equality, Actual);
+      if Op_Eq /= Null_Iir then
+         Op_Neq := Sem_Implicit_Operator_Association
+           (Std_Names.Name_Op_Inequality, Actual);
+         Set_Chain (Op_Eq, Op_Neq);
+         Set_Subprogram_Association_Chain (Assoc, Op_Eq);
+      end if;
    end Sem_Association_Type;
 
    --  Associate ASSOC with interface INTERFACE
diff --git a/src/vhdl/sem_inst.adb b/src/vhdl/sem_inst.adb
index 996eb06f2..cb52af129 100644
--- a/src/vhdl/sem_inst.adb
+++ b/src/vhdl/sem_inst.adb
@@ -650,7 +650,7 @@ package body Sem_Inst is
                declare
                   Inter_Type_Def : constant Iir :=
                     Get_Type (Get_Association_Interface (Assoc, Inter));
-                  Actual_Type : constant Iir := Get_Actual_Type (Assoc);
+                  Actual_Type : constant Iir := Get_Type (Get_Actual (Assoc));
                begin
                   Set_Instance (Inter_Type_Def, Actual_Type);
                end;
@@ -744,6 +744,22 @@ package body Sem_Inst is
                   Inter := Get_Association_Interface (Inst_El, Inter_El);
                   Set_Instance (Get_Type (Get_Origin (Inter)),
                                 Get_Type (Get_Actual (Inst_El)));
+                  --  Implicit operators.
+                  declare
+                     Imp_Inter : Iir;
+                     Imp_Assoc : Iir;
+                  begin
+                     Imp_Assoc := Get_Subprogram_Association_Chain (Inst_El);
+                     Imp_Inter := Get_Interface_Type_Subprograms
+                       (Get_Origin (Inter_El));
+                     while Is_Valid (Imp_Inter) and Is_Valid (Imp_Assoc) loop
+                        Set_Instance
+                          (Imp_Inter,
+                           Get_Named_Entity (Get_Actual (Imp_Assoc)));
+                        Imp_Inter := Get_Chain (Imp_Inter);
+                        Imp_Assoc := Get_Chain (Imp_Assoc);
+                     end loop;
+                  end;
                when Iir_Kind_Association_Element_Package =>
                   --  TODO.
                   raise Internal_Error;
diff --git a/src/vhdl/translate/ortho_front.adb b/src/vhdl/translate/ortho_front.adb
index 2c3da3189..667bbfe5b 100644
--- a/src/vhdl/translate/ortho_front.adb
+++ b/src/vhdl/translate/ortho_front.adb
@@ -222,8 +222,7 @@ package body Ortho_Front is
 
    --  Lighter version of libraries.is_obselete, since DESIGN_UNIT must be in
    --  the currently analyzed design file.
-   function Is_Obsolete (Design_Unit : Iir_Design_Unit)
-     return Boolean
+   function Is_Obsolete (Design_Unit : Iir_Design_Unit) return Boolean
    is
       List : Iir_List;
       El : Iir;
diff --git a/src/vhdl/translate/trans_be.adb b/src/vhdl/translate/trans_be.adb
index 64906f85c..81c0efa7e 100644
--- a/src/vhdl/translate/trans_be.adb
+++ b/src/vhdl/translate/trans_be.adb
@@ -76,6 +76,16 @@ package body Trans_Be is
 
       Canon.Canonicalize (Unit);
 
+      --  FIXME: for Main only ?
+      if Get_Kind (Lib) = Iir_Kind_Package_Declaration
+        and then not Get_Need_Body (Lib)
+        and then Get_Need_Instance_Bodies (Lib)
+      then
+         --  Create the bodies for instances
+         Set_Package_Instantiation_Bodies_Chain
+           (Lib, Canon.Create_Instantiation_Bodies (Lib));
+      end if;
+
       if (Main or Flags.Dump_All) and then Flags.Dump_Canon then
          Disp_Tree.Disp_Tree (Unit);
       end if;