exp_disp.adb (Export_DT): Addition of a new argument (Index)...

2009-04-09  Javier Miranda  <miranda@adacore.com>

	* exp_disp.adb (Export_DT): Addition of a new argument (Index); used to
	retrieve from the Dispatch_Table_Wrappers list the external name.
	Addition of documentation.
	(Make_Secondary_DT): Addition of a new argument (Suffix_Index) that is
	used to export secondary dispatch tables (in the previous version of
	the frontend only primary dispatch tables were exported). Addition of
	documentation.
	(Import_DT): New subprogram (internal of Make_Tags). Used to import a
	dispatch table of a given tagged type. 
	(Make_Tags): Modified to import secondary dispatch tables.

	* sem_ch3.adb (Analyze_Object_Declaration): Code cleanup.
	(Constant_Redeclaration): Code cleanup.

	* einfo.ads (Dispatch_Table_Wrapper): Renamed to
	Dispatch_Table_Wrappers.  Update documentation.

	* einfo.adb (Dispatch_Table_Wrapper, Set_Dispatch_Table_Wrapper):
	Renamed to Dispatch_Table_Wrappers.

	* sem_util.adb (Collect_Interface_Components): Improve handling of
	private types.

	* atree.ads (Elist26, Set_Elist26): New subprograms

	* atree.adb (Elist26, Set_Elist26): New subprograms

From-SVN: r145811

8 files changed, 338 insertions, 161 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index e6560e26..ebbc4d9 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,34 @@
 2009-04-09  Javier Miranda  <miranda@adacore.com>
 
+	* exp_disp.adb (Export_DT): Addition of a new argument (Index); used to
+	retrieve from the Dispatch_Table_Wrappers list the external name.
+	Addition of documentation.
+	(Make_Secondary_DT): Addition of a new argument (Suffix_Index) that is
+	used to export secondary dispatch tables (in the previous version of
+	the frontend only primary dispatch tables were exported). Addition of
+	documentation.
+	(Import_DT): New subprogram (internal of Make_Tags). Used to import a
+	dispatch table of a given tagged type. 
+	(Make_Tags): Modified to import secondary dispatch tables.
+
+	* sem_ch3.adb (Analyze_Object_Declaration): Code cleanup.
+	(Constant_Redeclaration): Code cleanup.
+
+	* einfo.ads (Dispatch_Table_Wrapper): Renamed to
+	Dispatch_Table_Wrappers.  Update documentation.
+
+	* einfo.adb (Dispatch_Table_Wrapper, Set_Dispatch_Table_Wrapper):
+	Renamed to Dispatch_Table_Wrappers.
+
+	* sem_util.adb (Collect_Interface_Components): Improve handling of
+	private types.
+
+	* atree.ads (Elist26, Set_Elist26): New subprograms
+
+	* atree.adb (Elist26, Set_Elist26): New subprograms
+
+2009-04-09  Javier Miranda  <miranda@adacore.com>
+
 	* sem_ch3.adb (Build_Derived_Record_Type): Fix typo.
 	(Derive_Progenitor_Subprograms): Handle interfaces in subtypes of
 	tagged types.
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index 67d8597..2c6a6e3 100644
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -3305,6 +3305,17 @@ package body Atree is
          end if;
       end Elist25;
 
+      function Elist26 (N : Node_Id) return Elist_Id is
+         pragma Assert (Nkind (N) in N_Entity);
+         Value : constant Union_Id := Nodes.Table (N + 4).Field8;
+      begin
+         if Value = 0 then
+            return No_Elist;
+         else
+            return Elist_Id (Value);
+         end if;
+      end Elist26;
+
       function Name1 (N : Node_Id) return Name_Id is
       begin
          pragma Assert (N <= Nodes.Last);
@@ -5422,6 +5433,12 @@ package body Atree is
          Nodes.Table (N + 4).Field7 := Union_Id (Val);
       end Set_Elist25;
 
+      procedure Set_Elist26 (N : Node_Id; Val : Elist_Id) is
+      begin
+         pragma Assert (Nkind (N) in N_Entity);
+         Nodes.Table (N + 4).Field8 := Union_Id (Val);
+      end Set_Elist26;
+
       procedure Set_Name1 (N : Node_Id; Val : Name_Id) is
       begin
          pragma Assert (N <= Nodes.Last);
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index ab9fdb4..824e62c 100644
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -1060,6 +1060,9 @@ package Atree is
       function Elist25 (N : Node_Id) return Elist_Id;
       pragma Inline (Elist25);
 
+      function Elist26 (N : Node_Id) return Elist_Id;
+      pragma Inline (Elist26);
+
       function Name1 (N : Node_Id) return Name_Id;
       pragma Inline (Name1);
 
@@ -2090,6 +2093,9 @@ package Atree is
       procedure Set_Elist25 (N : Node_Id; Val : Elist_Id);
       pragma Inline (Set_Elist25);
 
+      procedure Set_Elist26 (N : Node_Id; Val : Elist_Id);
+      pragma Inline (Set_Elist26);
+
       procedure Set_Name1 (N : Node_Id; Val : Name_Id);
       pragma Inline (Set_Name1);
 
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 9baaa3f..dcb6ada 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -214,7 +214,7 @@ package body Einfo is
    --    DT_Offset_To_Top_Func           Node25
    --    Task_Body_Procedure             Node25
 
-   --    Dispatch_Table_Wrapper          Node26
+   --    Dispatch_Table_Wrappers         Elist26
    --    Last_Assignment                 Node26
    --    Overridden_Operation            Node26
    --    Package_Instantiation           Node26
@@ -851,11 +851,11 @@ package body Einfo is
       return Uint15 (Id);
    end Discriminant_Number;
 
-   function Dispatch_Table_Wrapper (Id : E) return E is
+   function Dispatch_Table_Wrappers (Id : E) return L is
    begin
       pragma Assert (Is_Tagged_Type (Id));
-      return Node26 (Implementation_Base_Type (Id));
-   end Dispatch_Table_Wrapper;
+      return Elist26 (Implementation_Base_Type (Id));
+   end Dispatch_Table_Wrappers;
 
    function DT_Entry_Count (Id : E) return U is
    begin
@@ -3262,11 +3262,11 @@ package body Einfo is
       Set_Uint15 (Id, V);
    end Set_Discriminant_Number;
 
-   procedure Set_Dispatch_Table_Wrapper (Id : E; V : E) is
+   procedure Set_Dispatch_Table_Wrappers (Id : E; V : L) is
    begin
       pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id));
-      Set_Node26 (Id, V);
-   end Set_Dispatch_Table_Wrapper;
+      Set_Elist26 (Id, V);
+   end Set_Dispatch_Table_Wrappers;
 
    procedure Set_DT_Entry_Count (Id : E; V : U) is
    begin
@@ -8659,10 +8659,10 @@ package body Einfo is
 
          when E_Record_Type                                |
               E_Record_Type_With_Private                   =>
-            Write_Str ("Dispatch_Table_Wrapper");
+            Write_Str ("Dispatch_Table_Wrappers");
 
-         when E_In_Out_Parameter                               |
-              E_Out_Parameter                           |
+         when E_In_Out_Parameter                           |
+              E_Out_Parameter                              |
               E_Variable                                   =>
             Write_Str ("Last_Assignment");
 
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index bc2190c..3f5443f 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -816,11 +816,11 @@ package Einfo is
 --       the list of discriminants of the type, i.e. a sequential integer
 --       index starting at 1 and ranging up to Number_Discriminants.
 
---    Dispatch_Table_Wrapper (Node26) [implementation base type only]
+--    Dispatch_Table_Wrappers (Elist26) [implementation base type only]
 --       Present in library level record type entities if we are generating
 --       statically allocated dispatch tables. For a tagged type, points to
---       the dispatch table wrapper associated with the tagged type. For a
---       non-tagged record, contains Empty.
+--       the list of dispatch table wrappers associated with the tagged type.
+--       For a non-tagged record, contains No_Elist.
 
 --    DTC_Entity (Node16)
 --       Present in function and procedure entities. Set to Empty unless
@@ -5360,7 +5360,7 @@ package Einfo is
    --  E_Record_Subtype
    --    Primitive_Operations                (Elist15)
    --    Access_Disp_Table                   (Elist16)  (base type only)
-   --    Dispatch_Table_Wrapper              (Node26)   (base type only)
+   --    Dispatch_Table_Wrappers             (Elist26)  (base type only)
    --    Cloned_Subtype                      (Node16)   (subtype case only)
    --    First_Entity                        (Node17)
    --    Corresponding_Concurrent_Type       (Node18)
@@ -5395,7 +5395,7 @@ package Einfo is
    --  E_Record_Subtype_With_Private
    --    Primitive_Operations                (Elist15)
    --    Access_Disp_Table                   (Elist16)  (base type only)
-   --    Dispatch_Table_Wrapper              (Node26)   (base type only)
+   --    Dispatch_Table_Wrappers             (Elist26)  (base type only)
    --    First_Entity                        (Node17)
    --    Private_Dependents                  (Elist18)
    --    Underlying_Full_View                (Node19)
@@ -5785,7 +5785,7 @@ package Einfo is
    function Current_Value                       (Id : E) return N;
    function Debug_Info_Off                      (Id : E) return B;
    function Debug_Renaming_Link                 (Id : E) return E;
-   function Dispatch_Table_Wrapper              (Id : E) return E;
+   function Dispatch_Table_Wrappers             (Id : E) return L;
    function DTC_Entity                          (Id : E) return E;
    function DT_Entry_Count                      (Id : E) return U;
    function DT_Offset_To_Top_Func               (Id : E) return E;
@@ -6313,7 +6313,7 @@ package Einfo is
 
    procedure Set_Accept_Address                  (Id : E; V : L);
    procedure Set_Access_Disp_Table               (Id : E; V : L);
-   procedure Set_Dispatch_Table_Wrapper          (Id : E; V : E);
+   procedure Set_Dispatch_Table_Wrappers         (Id : E; V : L);
    procedure Set_Actual_Subtype                  (Id : E; V : E);
    procedure Set_Address_Taken                   (Id : E; V : B := True);
    procedure Set_Alias                           (Id : E; V : E);
@@ -6994,7 +6994,7 @@ package Einfo is
    pragma Inline (Current_Value);
    pragma Inline (Debug_Info_Off);
    pragma Inline (Debug_Renaming_Link);
-   pragma Inline (Dispatch_Table_Wrapper);
+   pragma Inline (Dispatch_Table_Wrappers);
    pragma Inline (DTC_Entity);
    pragma Inline (DT_Entry_Count);
    pragma Inline (DT_Offset_To_Top_Func);
@@ -7421,7 +7421,7 @@ package Einfo is
    pragma Inline (Set_Current_Value);
    pragma Inline (Set_Debug_Info_Off);
    pragma Inline (Set_Debug_Renaming_Link);
-   pragma Inline (Set_Dispatch_Table_Wrapper);
+   pragma Inline (Set_Dispatch_Table_Wrappers);
    pragma Inline (Set_DTC_Entity);
    pragma Inline (Set_DT_Entry_Count);
    pragma Inline (Set_DT_Offset_To_Top_Func);
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index b4f4429..66279a8 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -3150,13 +3150,19 @@ package body Exp_Disp is
       --  freezes a tagged type, when one of its primitive operations has a
       --  type in its profile whose full view has not been analyzed yet.
 
-      procedure Export_DT (Typ : Entity_Id; DT : Entity_Id);
-      --  Export the dispatch table entity DT of tagged type Typ. Required to
-      --  generate forward references and statically allocate the table.
+      procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
+      --  Export the dispatch table DT of tagged type Typ. Required to generate
+      --  forward references and statically allocate the table. For primary
+      --  dispatch tables Index is 0; for secondary dispatch tables the value
+      --  of index must match the Suffix_Index value assigned to the table by
+      --  Make_Tags when generating its unique external name, and it is used to
+      --  retrieve from the Dispatch_Table_Wrappers list associated with Typ
+      --  the external name generated by Import_DT.
 
       procedure Make_Secondary_DT
         (Typ              : Entity_Id;
          Iface            : Entity_Id;
+         Suffix_Index     : Int;
          Num_Iface_Prims  : Nat;
          Iface_DT_Ptr     : Entity_Id;
          Predef_Prims_Ptr : Entity_Id;
@@ -3171,7 +3177,12 @@ package body Exp_Disp is
       --  calls through interface types; the latter secondary table is
       --  generated when Build_Thunks is False, and provides support for
       --  Generic Dispatching Constructors that dispatch calls through
-      --  interface types.
+      --  interface types. When constructing this latter table the value
+      --  of Suffix_Index is -1 to indicate that there is no need to export
+      --  such table when building statically allocated dispatch tables; a
+      --  positive value of Suffix_Index must match the Suffix_Index value
+      --  assigned to this secondary dispatch table by Make_Tags when its
+      --  unique external name was generated.
 
       ------------------------------
       -- Check_Premature_Freezing --
@@ -3200,14 +3211,29 @@ package body Exp_Disp is
       -- Export_DT --
       ---------------
 
-      procedure Export_DT (Typ : Entity_Id; DT : Entity_Id) is
+      procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0)
+      is
+         Count : Nat;
+         Elmt  : Elmt_Id;
+
       begin
          Set_Is_Statically_Allocated (DT);
          Set_Is_True_Constant (DT);
          Set_Is_Exported (DT);
 
-         pragma Assert (Present (Dispatch_Table_Wrapper (Typ)));
-         Get_External_Name (Dispatch_Table_Wrapper (Typ), True);
+         Count := 0;
+         Elmt  := First_Elmt (Dispatch_Table_Wrappers (Typ));
+         while Count /= Index loop
+            Next_Elmt (Elmt);
+            Count := Count + 1;
+         end loop;
+
+         pragma Assert (Related_Type (Node (Elmt)) = Typ);
+
+         Get_External_Name
+           (Entity     => Node (Elmt),
+            Has_Suffix => True);
+
          Set_Interface_Name (DT,
            Make_String_Literal (Loc,
              Strval => String_From_Name_Buffer));
@@ -3225,6 +3251,7 @@ package body Exp_Disp is
       procedure Make_Secondary_DT
         (Typ              : Entity_Id;
          Iface            : Entity_Id;
+         Suffix_Index     : Int;
          Num_Iface_Prims  : Nat;
          Iface_DT_Ptr     : Entity_Id;
          Predef_Prims_Ptr : Entity_Id;
@@ -3232,13 +3259,16 @@ package body Exp_Disp is
          Result           : List_Id)
       is
          Loc                : constant Source_Ptr := Sloc (Typ);
-         Name_DT            : constant Name_Id := New_Internal_Name ('T');
+         Exporting_Table    : constant Boolean :=
+                                Building_Static_DT (Typ)
+                                  and then Suffix_Index > 0;
          Iface_DT           : constant Entity_Id :=
-                                Make_Defining_Identifier (Loc, Name_DT);
+                                Make_Defining_Identifier (Loc,
+                                  Chars => New_Internal_Name ('T'));
          Name_Predef_Prims  : constant Name_Id := New_Internal_Name ('R');
          Predef_Prims       : constant Entity_Id :=
                                 Make_Defining_Identifier (Loc,
-                                  Name_Predef_Prims);
+                                  Chars => Name_Predef_Prims);
          DT_Constr_List     : List_Id;
          DT_Aggr_List       : List_Id;
          Empty_DT           : Boolean := False;
@@ -3273,10 +3303,10 @@ package body Exp_Disp is
             Set_Is_True_Constant (Iface_DT);
          end if;
 
-         --  Generate code to create the storage for the Dispatch_Table object.
-         --  If the number of primitives of Typ is 0 we reserve a dummy single
-         --  entry for its DT because at run-time the pointer to this dummy
-         --  entry will be used as the tag.
+         --  Calculate the number of slots of the dispatch table. If the number
+         --  of primitives of Typ is 0 we reserve a dummy single entry for its
+         --  DT because at run-time the pointer to this dummy entry will be
+         --  used as the tag.
 
          if Num_Iface_Prims = 0 then
             Empty_DT := True;
@@ -3432,6 +3462,7 @@ package body Exp_Disp is
          --                                  prim-op-2'address,
          --                                  ...
          --                                  prim-op-n'address));
+         --   for Iface_DT'Alignment use Address'Alignment;
 
          --  Stage 3: Initialize the discriminant and the record components
 
@@ -3686,10 +3717,16 @@ package body Exp_Disp is
 
          Append_Elmt (New_Node, DT_Aggr);
 
+         --  Note: Secondary dispatch tables cannot be declared constant
+         --  because the component Offset_To_Top is currently initialized
+         --  by the IP routine.
+
          Append_To (Result,
            Make_Object_Declaration (Loc,
              Defining_Identifier => Iface_DT,
              Aliased_Present     => True,
+             Constant_Present    => False,
+
              Object_Definition   =>
                Make_Subtype_Indication (Loc,
                  Subtype_Mark => New_Reference_To
@@ -3697,54 +3734,68 @@ package body Exp_Disp is
                  Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
                                    Constraints => DT_Constr_List)),
 
-             Expression => Make_Aggregate (Loc,
-               Expressions => DT_Aggr_List)));
+             Expression          =>
+               Make_Aggregate (Loc,
+                 Expressions => DT_Aggr_List)));
 
          Append_To (Result,
            Make_Attribute_Definition_Clause (Loc,
              Name       => New_Reference_To (Iface_DT, Loc),
              Chars      => Name_Alignment,
+
              Expression =>
                Make_Attribute_Reference (Loc,
-                 Prefix =>
+                 Prefix         =>
                    New_Reference_To (RTE (RE_Integer_Address), Loc),
                  Attribute_Name => Name_Alignment)));
 
+         if Exporting_Table then
+            Export_DT (Typ, Iface_DT, Suffix_Index);
+
          --  Generate code to create the pointer to the dispatch table
 
-         --    Iface_DT_Ptr : Tag := Tag!(DT'Address);
+         --    Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
 
-         Append_To (Result,
-           Make_Object_Declaration (Loc,
-             Defining_Identifier => Iface_DT_Ptr,
-             Constant_Present    => True,
-             Object_Definition =>
-               New_Reference_To (RTE (RE_Interface_Tag), Loc),
-             Expression =>
-               Unchecked_Convert_To (RTE (RE_Interface_Tag),
-                 Make_Attribute_Reference (Loc,
-                   Prefix =>
-                     Make_Selected_Component (Loc,
-                       Prefix => New_Reference_To (Iface_DT, Loc),
-                     Selector_Name =>
-                       New_Occurrence_Of
-                         (RTE_Record_Component (RE_Prims_Ptr), Loc)),
-                   Attribute_Name => Name_Address))));
+         --  Note: This declaration is not added here if the table is exported
+         --  because in such case Make_Tags has already added this declaration.
+
+         else
+            Append_To (Result,
+              Make_Object_Declaration (Loc,
+                Defining_Identifier => Iface_DT_Ptr,
+                Constant_Present    => True,
+
+                Object_Definition   =>
+                  New_Reference_To (RTE (RE_Interface_Tag), Loc),
+
+                Expression          =>
+                  Unchecked_Convert_To (RTE (RE_Interface_Tag),
+                    Make_Attribute_Reference (Loc,
+                      Prefix         =>
+                        Make_Selected_Component (Loc,
+                          Prefix        => New_Reference_To (Iface_DT, Loc),
+                          Selector_Name =>
+                            New_Occurrence_Of
+                              (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+                      Attribute_Name => Name_Address))));
+         end if;
 
          Append_To (Result,
            Make_Object_Declaration (Loc,
              Defining_Identifier => Predef_Prims_Ptr,
              Constant_Present    => True,
-             Object_Definition =>
+
+             Object_Definition   =>
                New_Reference_To (RTE (RE_Address), Loc),
-             Expression =>
+
+             Expression          =>
                Make_Attribute_Reference (Loc,
-                 Prefix =>
+                 Prefix         =>
                    Make_Selected_Component (Loc,
-                     Prefix => New_Reference_To (Iface_DT, Loc),
-                   Selector_Name =>
-                     New_Occurrence_Of
-                       (RTE_Record_Component (RE_Predef_Prims), Loc)),
+                     Prefix        => New_Reference_To (Iface_DT, Loc),
+                     Selector_Name =>
+                       New_Occurrence_Of
+                         (RTE_Record_Component (RE_Predef_Prims), Loc)),
                  Attribute_Name => Name_Address)));
 
          --  Remember entities containing dispatch tables
@@ -3927,7 +3978,14 @@ package body Exp_Disp is
       if Has_Interfaces (Typ) then
          Collect_Interface_Components (Typ, Typ_Comps);
 
-         Suffix_Index := 0;
+         --  Each secondary dispatch table is assigned an unique positive
+         --  suffix index; such value also corresponds with the location of
+         --  its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
+
+         --  Note: This value must be kept sync with the Suffix_Index values
+         --  generated by Make_Tags
+
+         Suffix_Index := 1;
          AI_Tag_Elmt  :=
            Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
 
@@ -3939,17 +3997,19 @@ package body Exp_Disp is
             Make_Secondary_DT
              (Typ             => Typ,
               Iface           => Base_Type (Related_Type (Node (AI_Tag_Comp))),
+              Suffix_Index    => Suffix_Index,
               Num_Iface_Prims => UI_To_Int
                                    (DT_Entry_Count (Node (AI_Tag_Comp))),
               Iface_DT_Ptr    => Node (AI_Tag_Elmt),
               Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
               Build_Thunks    => True,
               Result          => Result);
-            Next_Elmt (AI_Tag_Elmt);
 
-            --  Skip the secondary dispatch table of predefined primitives
+            --  Skip secondary dispatch table and secondary dispatch table of
+            --  predefined primitives
 
             Next_Elmt (AI_Tag_Elmt);
+            Next_Elmt (AI_Tag_Elmt);
 
             --  Build the secondary table containing pointers to primitives
             --  (used to give support to Generic Dispatching Constructors).
@@ -3957,17 +4017,19 @@ package body Exp_Disp is
             Make_Secondary_DT
              (Typ             => Typ,
               Iface           => Base_Type (Related_Type (Node (AI_Tag_Comp))),
+              Suffix_Index    => -1,
               Num_Iface_Prims =>  UI_To_Int
                                    (DT_Entry_Count (Node (AI_Tag_Comp))),
               Iface_DT_Ptr    => Node (AI_Tag_Elmt),
               Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
               Build_Thunks    => False,
               Result          => Result);
-            Next_Elmt (AI_Tag_Elmt);
 
-            --  Skip the secondary dispatch table of predefined primitives
+            --  Skip secondary dispatch table and secondary dispatch table of
+            --  predefined primitives
 
             Next_Elmt (AI_Tag_Elmt);
+            Next_Elmt (AI_Tag_Elmt);
 
             Suffix_Index := Suffix_Index + 1;
             Next_Elmt (AI_Tag_Comp);
@@ -5177,7 +5239,8 @@ package body Exp_Disp is
          end if;
       end if;
 
-      --  Initialize the table of ancestor tags
+      --  Initialize the table of ancestor tags if not building static
+      --  dispatch table
 
       if not Building_Static_DT (Typ)
         and then not Is_Interface (Typ)
@@ -5202,11 +5265,10 @@ package body Exp_Disp is
                  (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
       end if;
 
-      --  Inherit the dispatch tables of the parent
-
-      --  There is no need to inherit anything from the parent when building
-      --  static dispatch tables because the whole dispatch table (including
-      --  inherited primitives) has been already built.
+      --  Inherit the dispatch tables of the parent. There is no need to
+      --  inherit anything from the parent when building static dispatch tables
+      --  because the whole dispatch table (including inherited primitives) has
+      --  been already built.
 
       if Building_Static_DT (Typ) then
          null;
@@ -5486,8 +5548,8 @@ package body Exp_Disp is
       Analyze_List (Result, Suppress => All_Checks);
       Set_Has_Dispatch_Table (Typ);
 
-      --  Mark entities containing dispatch tables. Required by the
-      --  backend to handle them properly.
+      --  Mark entities containing dispatch tables. Required by the backend to
+      --  handle them properly.
 
       if not Is_Interface (Typ) then
          declare
@@ -5687,57 +5749,38 @@ package body Exp_Disp is
    ---------------
 
    function Make_Tags (Typ : Entity_Id) return List_Id is
-      Loc              : constant Source_Ptr := Sloc (Typ);
-      Tname            : constant Name_Id := Chars (Typ);
-      Result           : constant List_Id := New_List;
-      AI_Tag_Comp      : Elmt_Id;
-      DT               : Node_Id;
-      DT_Constr_List   : List_Id;
-      DT_Ptr           : Node_Id;
-      Predef_Prims_Ptr : Node_Id;
-      Iface_DT_Ptr     : Node_Id;
-      Nb_Prim          : Nat;
-      Suffix_Index     : Int;
-      Typ_Name         : Name_Id;
-      Typ_Comps        : Elist_Id;
-
-   begin
-      --  1) Generate the primary and secondary tag entities
-
-      --  Collect the components associated with secondary dispatch tables
-
-      if Has_Interfaces (Typ) then
-         Collect_Interface_Components (Typ, Typ_Comps);
-      end if;
-
-      --  1) Generate the primary tag entities
-
-      --  Primary dispatch table containing user-defined primitives
-
-      DT_Ptr := Make_Defining_Identifier (Loc,
-                  New_External_Name (Tname, 'P'));
-      Set_Etype (DT_Ptr, RTE (RE_Tag));
-
-      --  Primary dispatch table containing predefined primitives
-
-      Predef_Prims_Ptr :=
-        Make_Defining_Identifier (Loc,
-          Chars => New_External_Name (Tname, 'Y'));
-      Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
-
-      --  Import the forward declaration of the Dispatch Table wrapper record
-      --  (Make_DT will take care of its exportation)
+      Loc    : constant Source_Ptr := Sloc (Typ);
+      Result : constant List_Id    := New_List;
+
+      procedure Import_DT
+        (Tag_Typ         : Entity_Id;
+         DT              : Entity_Id;
+         Is_Secondary_DT : Boolean);
+      --  Import the dispatch table DT of tagged type Tag_Typ. Required to
+      --  generate forward references and statically allocate the table. For
+      --  primary dispatch tables that require no dispatch table generate:
+      --     DT : static aliased constant Non_Dispatch_Table_Wrapper;
+      --     $pragma import (ada, DT);
+      --  Otherwise generate:
+      --     DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
+      --     $pragma import (ada, DT);
 
-      if Building_Static_DT (Typ) then
-         DT :=
-           Make_Defining_Identifier (Loc,
-             Chars => New_External_Name (Tname, 'T'));
+      ---------------
+      -- Import_DT --
+      ---------------
 
-         --  Generate:
-         --    DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
-         --    $pragma import (ada, DT);
+      procedure Import_DT
+        (Tag_Typ         : Entity_Id;
+         DT              : Entity_Id;
+         Is_Secondary_DT : Boolean)
+      is
+         DT_Constr_List : List_Id;
+         Nb_Prim        : Nat;
 
-         Set_Is_Imported (DT);
+      begin
+         Set_Is_Imported  (DT);
+         Set_Ekind        (DT, E_Constant);
+         Set_Related_Type (DT, Typ);
 
          --  The scope must be set now to call Get_External_Name
 
@@ -5754,14 +5797,27 @@ package body Exp_Disp is
 
          --  Save this entity to allow Make_DT to generate its exportation
 
-         Set_Dispatch_Table_Wrapper (Typ, DT);
+         Append_Elmt (DT, Dispatch_Table_Wrappers (Typ));
 
-         if Has_DT (Typ) then
+         --  No dispatch table required
 
+         if not Is_Secondary_DT
+           and then not Has_DT (Tag_Typ)
+         then
+            Append_To (Result,
+              Make_Object_Declaration (Loc,
+                Defining_Identifier => DT,
+                Aliased_Present     => True,
+                Constant_Present    => True,
+                Object_Definition   =>
+                  New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
+
+         else
             --  Calculate the number of primitives of the dispatch table and
             --  the size of the Type_Specific_Data record.
 
-            Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
+            Nb_Prim :=
+              UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ)));
 
             --  If the tagged type has no primitives we add a dummy slot
             --  whose address will be the tag of this type.
@@ -5785,7 +5841,61 @@ package body Exp_Disp is
                       New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
                     Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
                                     Constraints => DT_Constr_List))));
+         end if;
+      end Import_DT;
+
+      --  Local variables
+
+      Tname            : constant Name_Id := Chars (Typ);
+      AI_Tag_Comp      : Elmt_Id;
+      DT               : Node_Id;
+      DT_Ptr           : Node_Id;
+      Predef_Prims_Ptr : Node_Id;
+      Iface_DT         : Node_Id;
+      Iface_DT_Ptr     : Node_Id;
+      Suffix_Index     : Int;
+      Typ_Name         : Name_Id;
+      Typ_Comps        : Elist_Id;
+
+   --  Start of processing for Make_Tags
+
+   begin
+      --  1) Generate the primary and secondary tag entities
+
+      --  Collect the components associated with secondary dispatch tables
 
+      if Has_Interfaces (Typ) then
+         Collect_Interface_Components (Typ, Typ_Comps);
+      end if;
+
+      --  1) Generate the primary tag entities
+
+      --  Primary dispatch table containing user-defined primitives
+
+      DT_Ptr := Make_Defining_Identifier (Loc,
+                  New_External_Name (Tname, 'P'));
+      Set_Etype (DT_Ptr, RTE (RE_Tag));
+
+      --  Primary dispatch table containing predefined primitives
+
+      Predef_Prims_Ptr :=
+        Make_Defining_Identifier (Loc,
+          Chars => New_External_Name (Tname, 'Y'));
+      Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
+
+      --  Import the forward declaration of the Dispatch Table wrapper record
+      --  (Make_DT will take care of its exportation)
+
+      if Building_Static_DT (Typ) then
+         Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
+
+         DT :=
+           Make_Defining_Identifier (Loc,
+             Chars => New_External_Name (Tname, 'T'));
+
+         Import_DT (Typ, DT, Is_Secondary_DT => False);
+
+         if Has_DT (Typ) then
             Append_To (Result,
               Make_Object_Declaration (Loc,
                 Defining_Identifier => DT_Ptr,
@@ -5823,14 +5933,6 @@ package body Exp_Disp is
          else
             Append_To (Result,
               Make_Object_Declaration (Loc,
-                Defining_Identifier => DT,
-                Aliased_Present     => True,
-                Constant_Present    => True,
-                Object_Definition   =>
-                  New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
-
-            Append_To (Result,
-              Make_Object_Declaration (Loc,
                 Defining_Identifier => DT_Ptr,
                 Constant_Present    => True,
                 Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
@@ -5858,7 +5960,12 @@ package body Exp_Disp is
       --  2) Generate the secondary tag entities
 
       if Has_Interfaces (Typ) then
-         Suffix_Index := 0;
+
+         --  Note: The following value of Suffix_Index must be in sync with
+         --  the Suffix_Index values of secondary dispatch tables generated
+         --  by Make_DT.
+
+         Suffix_Index := 1;
 
          --  For each interface type we build an unique external name
          --  associated with its corresponding secondary dispatch table.
@@ -5872,9 +5979,19 @@ package body Exp_Disp is
          while Present (AI_Tag_Comp) loop
             Get_Secondary_DT_External_Name
               (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
-
             Typ_Name := Name_Find;
 
+            if Building_Static_DT (Typ) then
+               Iface_DT :=
+                 Make_Defining_Identifier (Loc,
+                   Chars => New_External_Name
+                              (Typ_Name, 'T', Suffix_Index => -1));
+               Import_DT
+                 (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
+                  DT      => Iface_DT,
+                  Is_Secondary_DT => True);
+            end if;
+
             --  Secondary dispatch table referencing thunks to user-defined
             --  primitives covered by this interface.
 
@@ -5892,6 +6009,25 @@ package body Exp_Disp is
               (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
             Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
 
+            if Building_Static_DT (Typ) then
+               Append_To (Result,
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Iface_DT_Ptr,
+                   Constant_Present    => True,
+                   Object_Definition   => New_Reference_To
+                                            (RTE (RE_Interface_Tag), Loc),
+                   Expression =>
+                     Unchecked_Convert_To (RTE (RE_Interface_Tag),
+                       Make_Attribute_Reference (Loc,
+                         Prefix =>
+                           Make_Selected_Component (Loc,
+                             Prefix => New_Reference_To (Iface_DT, Loc),
+                           Selector_Name =>
+                             New_Occurrence_Of
+                               (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+                         Attribute_Name => Name_Address))));
+            end if;
+
             --  Secondary dispatch table referencing thunks to predefined
             --  primitives.
 
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index c2f7790..a67048b 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -2416,17 +2416,6 @@ package body Sem_Ch3 is
       if Constant_Present (N)
         and then No (E)
       then
-         --  We exclude forward references to tags
-
-         if Is_Imported (Defining_Identifier (N))
-           and then
-             (T = RTE (RE_Tag)
-               or else
-                 (Present (Full_View (T))
-                   and then Full_View (T) = RTE (RE_Tag)))
-         then
-            null;
-
          --  A deferred constant may appear in the declarative part of the
          --  following constructs:
 
@@ -2444,7 +2433,7 @@ package body Sem_Ch3 is
          --  return statements are flagged as invalid contexts because they do
          --  not have a declarative part and so cannot accommodate the pragma.
 
-         elsif Ekind (Current_Scope) = E_Return_Statement then
+         if Ekind (Current_Scope) = E_Return_Statement then
             Error_Msg_N
               ("invalid context for deferred constant declaration (RM 7.4)",
                N);
@@ -9328,19 +9317,10 @@ package body Sem_Ch3 is
             Error_Msg_N ("ALIASED required (see declaration#)", N);
          end if;
 
-         --  Allow incomplete declaration of tags (used to handle forward
-         --  references to tags). The check on Ada_Tags avoids circularities
-         --  when rebuilding the compiler.
-
-         if RTU_Loaded (Ada_Tags)
-           and then T = RTE (RE_Tag)
-         then
-            null;
-
          --  Check that placement is in private part and that the incomplete
          --  declaration appeared in the visible part.
 
-         elsif Ekind (Current_Scope) = E_Package
+         if Ekind (Current_Scope) = E_Package
            and then not In_Private_Part (Current_Scope)
          then
             Error_Msg_Sloc := Sloc (Prev);
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index b265155..3f60ebc 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -1356,10 +1356,19 @@ package body Sem_Util is
       -------------
 
       procedure Collect (Typ : Entity_Id) is
-         Tag_Comp : Entity_Id;
+         Tag_Comp   : Entity_Id;
+         Parent_Typ : Entity_Id;
 
       begin
-         if Etype (Typ) /= Typ
+         --  Handle private types
+
+         if Present (Full_View (Etype (Typ))) then
+            Parent_Typ := Full_View (Etype (Typ));
+         else
+            Parent_Typ := Etype (Typ);
+         end if;
+
+         if Parent_Typ /= Typ
 
             --  Protect the frontend against wrong sources. For example:
 
@@ -1372,9 +1381,9 @@ package body Sem_Util is
             --      type C is new B with null record;
             --    end P;
 
-           and then Etype (Typ) /= Tagged_Type
+           and then Parent_Typ /= Tagged_Type
          then
-            Collect (Etype (Typ));
+            Collect (Parent_Typ);
          end if;
 
          --  Collect the components containing tags of secondary dispatch