exp_ch3.adb (Build_Record_Init_Proc/Freeze_Record_Type): Reimplementation of the…

exp_ch3.adb (Build_Record_Init_Proc/Freeze_Record_Type): Reimplementation of the support for abstract interface types in order to leave...

2005-07-07  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Build_Record_Init_Proc/Freeze_Record_Type):
	Reimplementation of the support for abstract interface types in order
	to leave the code more clear and easy to maintain.

	* exp_ch6.adb (Freeze_Subprogram): Reimplementation of the support for
	abstract interface types in order to leave the code clearer and easier
	to maintain.

	* exp_disp.ads, exp_disp.adb (Fill_DT_Entry): Part of its functionality
	is now implemented by the new subprogram Fill_Secondary_DT_Entry.
	(Fill_Secondary_DT_Entry): Generate the code necessary to fill the
	appropriate entry of the secondary dispatch table.
	(Make_DT): Add code to inherit the secondary dispatch tables of
	the ancestors.

	* exp_util.adb (Find_Interface_Tag/Find_Interface_ADT): Instead of
	implementing both functionalities by means of a common routine, each
	routine has its own code.

From-SVN: r101694

gcc/ada/exp_ch3.adb

@@ -1361,10 +1361,6 @@ package body Exp_Ch3 is
       Rec_Type    : Entity_Id;
       Set_Tag     : Entity_Id := Empty;
 
-      ADT      : Elmt_Id;
-      Aux_N    : Node_Id;
-      Aux_Comp : Node_Id;
-
       function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id;
       --  Build a assignment statement node which assigns to record
       --  component its default expression if defined. The left hand side
@@ -1735,6 +1731,100 @@ package body Exp_Ch3 is
          Record_Extension_Node : Node_Id;
          Init_Tag              : Node_Id;
 
+         procedure Init_Secondary_Tags (Typ : Entity_Id);
+         --  Ada 2005 (AI-251): Initialize the tags of all the secondary
+         --  tables associated with abstract interface types
+
+         -------------------------
+         -- Init_Secondary_Tags --
+         -------------------------
+
+         procedure Init_Secondary_Tags (Typ : Entity_Id) is
+            ADT : Elmt_Id;
+
+            procedure Init_Secondary_Tags_Internal (Typ : Entity_Id);
+            --  Internal subprogram used to recursively climb to the root type
+
+            ----------------------------------
+            -- Init_Secondary_Tags_Internal --
+            ----------------------------------
+
+            procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is
+               E     : Entity_Id;
+               Aux_N : Node_Id;
+
+            begin
+               if not Is_Interface (Typ)
+                 and then Etype (Typ) /= Typ
+               then
+                  Init_Secondary_Tags_Internal (Etype (Typ));
+               end if;
+
+               if Present (Abstract_Interfaces (Typ))
+                 and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
+               then
+                  E := First_Entity (Typ);
+                  while Present (E) loop
+                     if Is_Tag (E)
+                       and then Chars (E) /= Name_uTag
+                     then
+                        Aux_N := Node (ADT);
+                        pragma Assert (Present (Aux_N));
+
+                        --  Initialize the pointer to the secondary DT
+                        --  associated with the interface
+
+                        Append_To (Body_Stmts,
+                          Make_Assignment_Statement (Loc,
+                            Name =>
+                              Make_Selected_Component (Loc,
+                                Prefix => Make_Identifier (Loc, Name_uInit),
+                                Selector_Name =>
+                                  New_Reference_To (E, Loc)),
+                            Expression =>
+                              New_Reference_To (Aux_N, Loc)));
+
+                        --  Generate:
+                        --    Set_Offset_To_Top (DT_Ptr, n);
+
+                        Append_To (Body_Stmts,
+                          Make_Procedure_Call_Statement (Loc,
+                            Name => New_Reference_To
+                                      (RTE (RE_Set_Offset_To_Top), Loc),
+                            Parameter_Associations => New_List (
+                              Unchecked_Convert_To (RTE (RE_Tag),
+                                New_Reference_To (Aux_N, Loc)),
+                              Unchecked_Convert_To (RTE (RE_Storage_Offset),
+                                Make_Attribute_Reference (Loc,
+                                  Prefix         =>
+                                   Make_Selected_Component (Loc,
+                                     Prefix         => Make_Identifier (Loc,
+                                                         Name_uInit),
+                                     Selector_Name  => New_Reference_To
+                                                         (E, Loc)),
+                                 Attribute_Name => Name_Position)))));
+
+                        Next_Elmt (ADT);
+                     end if;
+
+                     Next_Entity (E);
+                  end loop;
+               end if;
+            end Init_Secondary_Tags_Internal;
+
+         --  Start of processing for Init_Secondary_Tags
+
+         begin
+            --  Skip the first _Tag, which is the main tag of the
+            --  tagged type. Following tags correspond with abstract
+            --  interfaces.
+
+            ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+            Init_Secondary_Tags_Internal (Typ);
+         end Init_Secondary_Tags;
+
+      --  Start of processing for Build_Init_Procedure
+
       begin
          Body_Stmts := New_List;
          Body_Node := New_Node (N_Subprogram_Body, Loc);
@@ -1864,55 +1954,10 @@ package body Exp_Ch3 is
                --  Ada 2005 (AI-251): Initialization of all the tags
                --  corresponding with abstract interfaces
 
-               if Present (First_Tag_Component (Rec_Type)) then
-
-                  --  Skip the first _Tag, which is the main tag of the
-                  --  tagged type. Following tags correspond with abstract
-                  --  interfaces.
-
-                  Aux_Comp :=
-                    Next_Tag_Component (First_Tag_Component (Rec_Type));
-
-                  ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Rec_Type)));
-                  while Present (ADT) loop
-                     Aux_N := Node (ADT);
-
-                     --  Initialize the pointer to the secondary DT associated
-                     --  with the interface
-
-                     Append_To (Body_Stmts,
-                       Make_Assignment_Statement (Loc,
-                         Name =>
-                           Make_Selected_Component (Loc,
-                             Prefix => Make_Identifier (Loc, Name_uInit),
-                             Selector_Name =>
-                               New_Reference_To (Aux_Comp, Loc)),
-                         Expression =>
-                           New_Reference_To (Aux_N, Loc)));
-
-                     --  Generate:
-                     --    Set_Offset_To_Top (DT_Ptr, n);
-
-                     Append_To (Body_Stmts,
-                       Make_Procedure_Call_Statement (Loc,
-                         Name => New_Reference_To (RTE (RE_Set_Offset_To_Top),
-                                                   Loc),
-                         Parameter_Associations => New_List (
-                           Unchecked_Convert_To (RTE (RE_Tag),
-                             New_Reference_To (Aux_N, Loc)),
-                           Unchecked_Convert_To (RTE (RE_Storage_Offset),
-                             Make_Attribute_Reference (Loc,
-                               Prefix         =>
-                                Make_Selected_Component (Loc,
-                                  Prefix         => Make_Identifier (Loc,
-                                                      Name_uInit),
-                                  Selector_Name  => New_Reference_To
-                                                      (Aux_Comp, Loc)),
-                              Attribute_Name => Name_Position)))));
-
-                     Aux_Comp := Next_Tag_Component (Aux_Comp);
-                     Next_Elmt (ADT);
-                  end loop;
+               if Ada_Version >= Ada_05
+                 and then not Is_Interface (Rec_Type)
+               then
+                  Init_Secondary_Tags (Rec_Type);
                end if;
 
             else
@@ -4480,36 +4525,6 @@ package body Exp_Ch3 is
                Expand_Tagged_Root (Def_Id);
             end if;
 
-            --  Build the secondary tables
-
-            if not Java_VM
-              and then Present (Abstract_Interfaces (Def_Id))
-              and then not Is_Empty_Elmt_List (Abstract_Interfaces (Def_Id))
-            then
-               declare
-                  E      : Entity_Id;
-                  Result : List_Id;
-                  ADT    : Elist_Id := Access_Disp_Table (Def_Id);
-
-               begin
-                  E := First_Entity (Def_Id);
-                  while Present (E) loop
-                     if Is_Tag (E) and then Chars (E) /= Name_uTag then
-                        Make_Abstract_Interface_DT
-                          (AI_Tag          => E,
-                           Acc_Disp_Tables => ADT,
-                           Result          => Result);
-
-                        Append_Freeze_Actions (Def_Id, Result);
-                     end if;
-
-                     Next_Entity (E);
-                  end loop;
-
-                  Set_Access_Disp_Table (Def_Id, ADT);
-               end;
-            end if;
-
             --  Unfreeze momentarily the type to add the predefined primitives
             --  operations. The reason we unfreeze is so that these predefined
             --  operations will indeed end up as primitive operations (which
@@ -4533,7 +4548,55 @@ package body Exp_Ch3 is
             --  dispatching mechanism is handled internally by the JVM.
 
             if not Java_VM then
-               Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
+
+               --  Ada 2005 (AI-251): Build the secondary dispatch tables
+
+               declare
+                  ADT : Elist_Id := Access_Disp_Table (Def_Id);
+
+                  procedure Add_Secondary_Tables (Typ : Entity_Id);
+                  --  Comment required ???
+
+                  --------------------------
+                  -- Add_Secondary_Tables --
+                  --------------------------
+
+                  procedure Add_Secondary_Tables (Typ : Entity_Id) is
+                     E      : Entity_Id;
+                     Result : List_Id;
+
+                  begin
+                     if Etype (Typ) /= Typ then
+                        Add_Secondary_Tables (Etype (Typ));
+                     end if;
+
+                     if Present (Abstract_Interfaces (Typ))
+                       and then not Is_Empty_Elmt_List
+                                      (Abstract_Interfaces (Typ))
+                     then
+                        E := First_Entity (Typ);
+                        while Present (E) loop
+                           if Is_Tag (E) and then Chars (E) /= Name_uTag then
+                              Make_Abstract_Interface_DT
+                                (AI_Tag          => E,
+                                 Acc_Disp_Tables => ADT,
+                                 Result          => Result);
+
+                              Append_Freeze_Actions (Def_Id, Result);
+                           end if;
+
+                           Next_Entity (E);
+                        end loop;
+                     end if;
+                  end Add_Secondary_Tables;
+
+               --  Start of processing to build secondary dispatch tables
+
+               begin
+                  Add_Secondary_Tables  (Def_Id);
+                  Set_Access_Disp_Table (Def_Id, ADT);
+                  Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
+               end;
             end if;
 
             --  Make sure that the primitives Initialize, Adjust and Finalize
@@ -5681,7 +5744,7 @@ package body Exp_Ch3 is
 
         Ret_Type => Standard_Integer));
 
-      --  Specs for dispatching stream attributes.
+      --  Specs for dispatching stream attributes
 
       declare
          Stream_Op_TSS_Names :

gcc/ada/exp_ch6.adb

@@ -4062,37 +4062,157 @@ package body Exp_Ch6 is
    procedure Freeze_Subprogram (N : Node_Id) is
       Loc       : constant Source_Ptr := Sloc (N);
       E         : constant Entity_Id  := Entity (N);
-      Thunk_Id  : Entity_Id;
-      Iface_Tag : Entity_Id;
-      New_Thunk : Node_Id;
 
-   begin
-      --  When a primitive is frozen, enter its name in the corresponding
-      --  dispatch table. If the DTC_Entity field is not set this is an
-      --  overridden primitive that can be ignored. We suppress the
-      --  initialization of the dispatch table entry when Java_VM because
-      --  the dispatching mechanism is handled internally by the JVM.
+      procedure Check_Overriding_Inherited_Interfaces (E : Entity_Id);
+      --  (Ada 2005): Check if the primitive E covers some interface already
+      --  implemented by some ancestor of the tagged-type associated with E
+
+      procedure Register_Interface_DT_Entry
+        (Prim                : Entity_Id;
+         Ancestor_Iface_Prim : Entity_Id := Empty);
+      --  (Ada 2005): Register an interface primitive in a secondary dispatch
+      --  table. If Prim overrides an ancestor primitive of its associated
+      --  tagged-type then Ancestor_Iface_Prim indicates the entity of that
+      --  immediate ancestor associated with the interface; otherwise Prim and
+      --  Ancestor_Iface_Prim have the same info.
+
+      -------------------------------------------
+      -- Check_Overriding_Inherited_Interfaces --
+      -------------------------------------------
+
+      procedure Check_Overriding_Inherited_Interfaces (E : Entity_Id) is
+         Typ          : Entity_Id;
+         Elmt         : Elmt_Id;
+         Prim_Op      : Entity_Id;
+         Overriden_Op : Entity_Id := Empty;
 
-      if Is_Dispatching_Operation (E)
-        and then not Is_Abstract (E)
-        and then Present (DTC_Entity (E))
-        and then not Is_CPP_Class (Scope (DTC_Entity (E)))
-        and then not Java_VM
-      then
-         Check_Overriding_Operation (E);
+      begin
+         if Ada_Version < Ada_05
+           or else not Is_Overriding_Operation (E)
+           or else Is_Predefined_Dispatching_Operation (E)
+           or else Present (Alias (E))
+         then
+            return;
+         end if;
+
+         --  Get the entity associated with this primitive operation
+
+         Typ := Scope (DTC_Entity (E));
+         while Etype (Typ) /= Typ loop
+
+            --  Climb to the immediate ancestor
+
+            Typ := Etype (Typ);
 
-         --  Common case: Primitive subprogram
+            if Present (Abstract_Interfaces (Typ)) then
 
-         if not Present (Abstract_Interface_Alias (E)) then
-            Insert_After (N, Fill_DT_Entry (Sloc (N), E));
+               --  Look for the overriden subprogram in the primary dispatch
+               --  table of the ancestor.
 
-         --  Ada 2005 (AI-251): Primitive subprogram that covers an interface
+               Overriden_Op := Empty;
+               Elmt         := First_Elmt (Primitive_Operations (Typ));
+               while Present (Elmt) loop
+                  Prim_Op := Node (Elmt);
+
+                  if DT_Position (Prim_Op) = DT_Position (E)
+                    and then Etype (DTC_Entity (Prim_Op)) = RTE (RE_Tag)
+                    and then not Present (Abstract_Interface_Alias (Prim_Op))
+                  then
+                     if Overriden_Op /= Empty then
+                        raise Program_Error;
+                     end if;
+
+                     Overriden_Op := Prim_Op;
+                  end if;
+
+                  Next_Elmt (Elmt);
+               end loop;
+
+               --  if not found this is the first overriding of some
+               --  abstract interface
+
+               if Overriden_Op /= Empty then
+                  Elmt := First_Elmt (Primitive_Operations (Typ));
+
+                  --  Find the entries associated with interfaces that are
+                  --  alias of this primitive operation in the ancestor
+
+                  while Present (Elmt) loop
+                     Prim_Op := Node (Elmt);
+
+                     if Present (Abstract_Interface_Alias (Prim_Op))
+                       and then Alias (Prim_Op) = Overriden_Op
+                     then
+                        Register_Interface_DT_Entry (E, Prim_Op);
+                     end if;
+
+                     Next_Elmt (Elmt);
+                  end loop;
+               end if;
+            end if;
+         end loop;
+      end Check_Overriding_Inherited_Interfaces;
+
+      ---------------------------------
+      -- Register_Interface_DT_Entry --
+      ---------------------------------
+
+      procedure Register_Interface_DT_Entry
+        (Prim                : Entity_Id;
+         Ancestor_Iface_Prim : Entity_Id := Empty)
+      is
+         Prim_Typ     : Entity_Id;
+         Prim_Op      : Entity_Id;
+         Iface_Typ    : Entity_Id;
+         Iface_DT_Ptr : Entity_Id;
+         Iface_Tag    : Entity_Id;
+         New_Thunk    : Node_Id;
+         Thunk_Id     : Entity_Id;
+
+      begin
+         if not Present (Ancestor_Iface_Prim) then
+            Prim_Typ  := Scope (DTC_Entity (Alias (Prim)));
+            Iface_Typ := Scope (DTC_Entity (Abstract_Interface_Alias (Prim)));
+            Iface_Tag := Find_Interface_Tag
+                           (T     => Prim_Typ,
+                            Iface => Iface_Typ);
+
+            --  Generate the code of the thunk only when this primitive
+            --  operation is associated with a secondary dispatch table
+
+            if Etype (Iface_Tag) = RTE (RE_Interface_Tag) then
+               Thunk_Id  := Make_Defining_Identifier (Loc,
+                              New_Internal_Name ('T'));
+               New_Thunk :=
+                 Expand_Interface_Thunk
+                   (N           => Prim,
+                    Thunk_Alias => Alias (Prim),
+                    Thunk_Id    => Thunk_Id,
+                    Iface_Tag   => Iface_Tag);
+
+               Insert_After (N, New_Thunk);
+
+               Iface_DT_Ptr :=
+                 Find_Interface_ADT
+                   (T     => Prim_Typ,
+                    Iface => Iface_Typ);
+
+               Insert_After (New_Thunk,
+                 Fill_Secondary_DT_Entry (Sloc (Prim),
+                   Prim         => Prim,
+                   Iface_DT_Ptr => Iface_DT_Ptr,
+                   Thunk_Id     => Thunk_Id));
+            end if;
 
          else
+            Iface_Typ :=
+              Scope (DTC_Entity (Abstract_Interface_Alias
+                                  (Ancestor_Iface_Prim)));
+
             Iface_Tag :=
               Find_Interface_Tag
-                (T     => Scope (DTC_Entity (Alias (E))),    -- Formal Type
-                 Iface => Scope (DTC_Entity (Abstract_Interface_Alias (E))));
+                (T     => Scope (DTC_Entity (Alias (Ancestor_Iface_Prim))),
+                 Iface => Iface_Typ);
 
             --  Generate the thunk only if the associated tag is an interface
             --  tag. The case in which the associated tag is the primary tag
@@ -4107,12 +4227,69 @@ package body Exp_Ch6 is
                Thunk_Id  := Make_Defining_Identifier (Loc,
                               New_Internal_Name ('T'));
 
-               New_Thunk := Expand_Interface_Thunk (N, Thunk_Id, Iface_Tag);
+               if Present (Alias (Prim)) then
+                  Prim_Op := Alias (Prim);
+               else
+                  Prim_Op := Prim;
+               end if;
+
+               New_Thunk :=
+                 Expand_Interface_Thunk
+                   (N           => Ancestor_Iface_Prim,
+                    Thunk_Alias => Prim_Op,
+                    Thunk_Id    => Thunk_Id,
+                    Iface_Tag   => Iface_Tag);
+
+               Insert_After (N, New_Thunk);
+
+               Iface_DT_Ptr :=
+                 Find_Interface_ADT
+                   (T     => Scope (DTC_Entity (Prim_Op)),
+                    Iface => Iface_Typ);
 
                Insert_After (New_Thunk,
-                  Fill_DT_Entry (Sloc (N),
-                     Prim     => E,
-                     Thunk_Id => Thunk_Id));
+                 Fill_Secondary_DT_Entry (Sloc (Prim),
+                   Prim         => Ancestor_Iface_Prim,
+                   Iface_DT_Ptr => Iface_DT_Ptr,
+                   Thunk_Id     => Thunk_Id));
+            end if;
+         end if;
+      end Register_Interface_DT_Entry;
+
+   --  Start of processing for Freeze_Subprogram
+
+   begin
+      --  When a primitive is frozen, enter its name in the corresponding
+      --  dispatch table. If the DTC_Entity field is not set this is an
+      --  overridden primitive that can be ignored. We suppress the
+      --  initialization of the dispatch table entry when Java_VM because
+      --  the dispatching mechanism is handled internally by the JVM.
+
+      if Is_Dispatching_Operation (E)
+        and then not Is_Abstract (E)
+        and then Present (DTC_Entity (E))
+        and then not Java_VM
+        and then not Is_CPP_Class (Scope (DTC_Entity (E)))
+      then
+         Check_Overriding_Operation (E);
+
+         if Ada_Version < Ada_05 then
+            Insert_After (N,
+              Fill_DT_Entry (Sloc (N), Prim => E));
+
+         else
+            --  Ada 2005 (AI-251): Check if this entry corresponds with
+            --  a subprogram that covers an abstract interface type
+
+            if Present (Abstract_Interface_Alias (E)) then
+               Register_Interface_DT_Entry (E);
+
+            --  Common case: Primitive subprogram
+
+            else
+               Insert_After (N,
+                 Fill_DT_Entry (Sloc (N), Prim => E));
+               Check_Overriding_Inherited_Interfaces (E);
             end if;
          end if;
       end if;

gcc/ada/exp_disp.adb

@@ -902,6 +902,7 @@ package body Exp_Disp is
 
    function Expand_Interface_Thunk
      (N           : Node_Id;
+      Thunk_Alias : Entity_Id;
       Thunk_Id    : Entity_Id;
       Iface_Tag   : Entity_Id) return Node_Id
    is
@@ -910,7 +911,6 @@ package body Exp_Disp is
       Decl        : constant List_Id    := New_List;
       Formals     : constant List_Id    := New_List;
       Thunk_Tag   : constant Node_Id    := Iface_Tag;
-      Thunk_Alias : constant Entity_Id  := Alias (Entity (N));
       Target      : Entity_Id;
       New_Code    : Node_Id;
       Formal      : Node_Id;
@@ -950,11 +950,7 @@ package body Exp_Disp is
 
          if Is_Controlling_Formal (Formal) then
             Set_Parameter_Type (New_Formal,
-              New_Reference_To (Etype (First_Entity (Entity (N))), Loc));
-
-            --  Why is this line silently commented out ???
-
-            --  New_Reference_To (Etype (Formal), Loc));
+              New_Reference_To (Etype (First_Entity (N)), Loc));
          end if;
 
          Append_To (Formals, New_Formal);
@@ -1150,66 +1146,76 @@ package body Exp_Disp is
       end if;
 
       Analyze (New_Code);
-      Insert_After (N, New_Code);
       return New_Code;
    end Expand_Interface_Thunk;
 
-   -------------
-   -- Fill_DT --
-   -------------
+   -------------------
+   -- Fill_DT_Entry --
+   -------------------
 
    function Fill_DT_Entry
-     (Loc      : Source_Ptr;
-      Prim     : Entity_Id;
-      Thunk_Id : Entity_Id := Empty) return Node_Id
+     (Loc     : Source_Ptr;
+      Prim    : Entity_Id) return Node_Id
    is
       Typ     : constant Entity_Id := Scope (DTC_Entity (Prim));
-      DT_Ptr  : Entity_Id := Node (First_Elmt (Access_Disp_Table (Typ)));
-      Target  : Entity_Id;
-      Tag     : Entity_Id := First_Tag_Component (Typ);
-      Prim_Op : Entity_Id := Prim;
+      DT_Ptr  : constant Entity_Id :=
+                  Node (First_Elmt (Access_Disp_Table (Typ)));
+      Pos     : constant Uint      := DT_Position (Prim);
+      Tag     : constant Entity_Id := First_Tag_Component (Typ);
 
    begin
-      --  Ada 2005 (AI-251): If we have a thunk available then generate code
-      --  that saves its address in the secondary dispatch table of its
-      --  abstract interface; otherwise save the address of the primitive
-      --  subprogram in the main virtual table.
-
-      if Thunk_Id /= Empty then
-         Target := Thunk_Id;
-      else
-         Target := Prim;
+      if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then
+         raise Program_Error;
       end if;
 
-      --  Ada 2005 (AI-251): If the subprogram is the alias of an abstract
-      --  interface subprogram then find the correct dispatch table pointer
+      return
+        Make_DT_Access_Action (Typ,
+          Action => Set_Prim_Op_Address,
+          Args   => New_List (
+            Unchecked_Convert_To (RTE (RE_Tag),
+              New_Reference_To (DT_Ptr, Loc)),                  -- DTptr
 
-      if Present (Abstract_Interface_Alias (Prim)) then
-         Prim_Op := Abstract_Interface_Alias (Prim);
+            Make_Integer_Literal (Loc, Pos),                    -- Position
 
-         DT_Ptr  := Find_Interface_ADT
-                      (T     => Typ,
-                       Iface => Scope (DTC_Entity (Prim_Op)));
+            Make_Attribute_Reference (Loc,                      -- Value
+              Prefix          => New_Reference_To (Prim, Loc),
+              Attribute_Name  => Name_Address)));
+   end Fill_DT_Entry;
 
-         Tag := First_Tag_Component (Scope (DTC_Entity (Prim_Op)));
-      end if;
+   -----------------------------
+   -- Fill_Secondary_DT_Entry --
+   -----------------------------
 
-      pragma Assert (DT_Position (Prim_Op) <= DT_Entry_Count (Tag));
-      pragma Assert (DT_Position (Prim_Op) > Uint_0);
+   function Fill_Secondary_DT_Entry
+     (Loc          : Source_Ptr;
+      Prim         : Entity_Id;
+      Thunk_Id     : Entity_Id;
+      Iface_DT_Ptr : Entity_Id) return Node_Id
+   is
+      Typ        : constant Entity_Id := Scope (DTC_Entity (Alias (Prim)));
+      Iface_Prim : constant Entity_Id := Abstract_Interface_Alias (Prim);
+      Pos        : constant Uint      := DT_Position (Iface_Prim);
+      Tag        : constant Entity_Id :=
+                     First_Tag_Component (Scope (DTC_Entity (Iface_Prim)));
+
+   begin
+      if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then
+         raise Program_Error;
+      end if;
 
       return
         Make_DT_Access_Action (Typ,
           Action => Set_Prim_Op_Address,
           Args   => New_List (
             Unchecked_Convert_To (RTE (RE_Tag),
-              New_Reference_To (DT_Ptr, Loc)),                  -- DTptr
+              New_Reference_To (Iface_DT_Ptr, Loc)),            -- DTptr
 
-            Make_Integer_Literal (Loc, DT_Position (Prim_Op)),  -- Position
+            Make_Integer_Literal (Loc, Pos),                    -- Position
 
             Make_Attribute_Reference (Loc,                      -- Value
-              Prefix          => New_Reference_To (Target, Loc),
+              Prefix          => New_Reference_To (Thunk_Id, Loc),
               Attribute_Name  => Name_Address)));
-   end Fill_DT_Entry;
+   end Fill_Secondary_DT_Entry;
 
    ---------------------------
    -- Get_Remotely_Callable --
@@ -1313,7 +1319,6 @@ package body Exp_Disp is
       Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
 
       --  ----------------------------------------------------------------
-
       --  Dispatch table and related entities are allocated statically
 
       Set_Ekind (DT, E_Variable);
@@ -1538,6 +1543,71 @@ package body Exp_Disp is
             Node3 => Make_Integer_Literal (Loc,
                        DT_Entry_Count (First_Tag_Component (Etype (Typ)))))));
 
+      --  Inherit the secondary dispatch tables of the ancestor
+
+      if not Is_CPP_Class (Etype (Typ)) then
+         declare
+            Sec_DT_Ancestor : Elmt_Id :=
+              Next_Elmt (First_Elmt (Access_Disp_Table (Etype (Typ))));
+            Sec_DT_Typ      : Elmt_Id :=
+              Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+
+            procedure Copy_Secondary_DTs (Typ : Entity_Id);
+            --  ??? comment required
+
+            ------------------------
+            -- Copy_Secondary_DTs --
+            ------------------------
+
+            procedure Copy_Secondary_DTs (Typ : Entity_Id) is
+               E : Entity_Id;
+
+            begin
+               if Etype (Typ) /= Typ then
+                  Copy_Secondary_DTs (Etype (Typ));
+               end if;
+
+               if Present (Abstract_Interfaces (Typ))
+                 and then not Is_Empty_Elmt_List
+                                (Abstract_Interfaces (Typ))
+               then
+                  E := First_Entity (Typ);
+
+                  while Present (E)
+                    and then Present (Node (Sec_DT_Ancestor))
+                  loop
+                     if Is_Tag (E) and then Chars (E) /= Name_uTag then
+                        Append_To (Elab_Code,
+                          Make_DT_Access_Action (Typ,
+                            Action => Inherit_DT,
+                            Args   => New_List (
+                              Node1 => Unchecked_Convert_To
+                                         (RTE (RE_Tag),
+                                          New_Reference_To
+                                            (Node (Sec_DT_Ancestor), Loc)),
+                              Node2 => Unchecked_Convert_To
+                                         (RTE (RE_Tag),
+                                          New_Reference_To
+                                            (Node (Sec_DT_Typ), Loc)),
+                              Node3 => Make_Integer_Literal (Loc,
+                                         DT_Entry_Count (E)))));
+
+                        Next_Elmt (Sec_DT_Ancestor);
+                        Next_Elmt (Sec_DT_Typ);
+                     end if;
+
+                     Next_Entity (E);
+                  end loop;
+               end if;
+            end Copy_Secondary_DTs;
+
+         begin
+            if Present (Node (Sec_DT_Ancestor)) then
+               Copy_Secondary_DTs (Typ);
+            end if;
+         end;
+      end if;
+
       --  Generate: Inherit_TSD (parent'tag, DT_Ptr);
 
       Append_To (Elab_Code,
@@ -1547,17 +1617,20 @@ package body Exp_Disp is
             Node1 => Old_Tag2,
             Node2 => New_Reference_To (DT_Ptr, Loc))));
 
-      --  for types with no controlled components
-      --    Generate: Set_RC_Offset (DT_Ptr, 0);
-      --  for simple types with controlled components
-      --    Generate: Set_RC_Offset (DT_Ptr, type._record_controller'position);
-      --  for complex types with controlled components where the position
+      --  For types with no controlled components, generate:
+      --    Set_RC_Offset (DT_Ptr, 0);
+
+      --  For simple types with controlled components, generate:
+      --    Set_RC_Offset (DT_Ptr, type._record_controller'position);
+
+      --  For complex types with controlled components where the position
       --  of the record controller is not statically computable, if there are
-      --  controlled components at this level
-      --    Generate: Set_RC_Offset (DT_Ptr, -1);
-      --  to indicate that the _controller field is right after the _parent or
-      --  if there are no controlled components at this level,
-      --    Generate: Set_RC_Offset (DT_Ptr, -2);
+      --  controlled components at this level, generate:
+      --    Set_RC_Offset (DT_Ptr, -1);
+      --  to indicate that the _controller field is right after the _parent
+
+      --  Or if there are no controlled components at this level, generate:
+      --    Set_RC_Offset (DT_Ptr, -2);
       --  to indicate that we need to get the position from the parent.
 
       declare
@@ -1588,6 +1661,8 @@ package body Exp_Disp is
             --  the back end (see comment on the Bit_Component attribute in
             --  sem_attr). So we avoid semantic checking here.
 
+            --  Is this documented in sinfo.ads??? it should be!
+
             Set_Analyzed (Position);
             Set_Etype (Prefix (Position), RTE (RE_Record_Controller));
             Set_Etype (Prefix (Prefix (Position)), Typ);
@@ -1604,8 +1679,8 @@ package body Exp_Disp is
                Node2 => Position)));
       end;
 
-      --  Generate: Set_Remotely_Callable (DT_Ptr, Status);
-      --  where Status is described in E.4 (18)
+      --  Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is
+      --  described in E.4 (18)
 
       declare
          Status : Entity_Id;
@@ -1681,8 +1756,8 @@ package body Exp_Disp is
       --  Ada 2005 (AI-251): Register the tag of the interfaces into
       --  the table of implemented interfaces
 
-      if Present (Abstract_Interfaces (Typ))
-        and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
+      if Present (Abstract_Interfaces (Typ_Copy))
+        and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ_Copy))
       then
          AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
          while Present (AI) loop
@@ -1718,9 +1793,8 @@ package body Exp_Disp is
       Result          : out List_Id)
    is
       Loc         : constant Source_Ptr := Sloc (AI_Tag);
-      Tname       : constant Name_Id := Chars (AI_Tag);
-      Name_DT     : constant Name_Id := New_External_Name (Tname, 'T');
-      Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
+      Name_DT     : constant Name_Id := New_Internal_Name ('T');
+      Name_DT_Ptr : constant Name_Id := New_Internal_Name ('P');
 
       Iface_DT     : constant Node_Id :=
                        Make_Defining_Identifier (Loc, Name_DT);
@@ -1848,7 +1922,6 @@ package body Exp_Disp is
       end if;
 
       Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables);
-
    end Make_Abstract_Interface_DT;
 
    ---------------------------
@@ -2117,6 +2190,7 @@ package body Exp_Disp is
 
          Prim_Elmt  := First_Prim;
          Count_Prim := 0;
+
          while Present (Prim_Elmt) loop
             Count_Prim := Count_Prim + 1;
             Prim       := Node (Prim_Elmt);

gcc/ada/exp_disp.ads

@@ -55,12 +55,20 @@ package Exp_Disp is
        TSD_Prologue_Size);
 
    function Fill_DT_Entry
-     (Loc      : Source_Ptr;
-      Prim     : Entity_Id;
-      Thunk_Id : Entity_Id := Empty) return Node_Id;
+     (Loc          : Source_Ptr;
+      Prim         : Entity_Id) return Node_Id;
    --  Generate the code necessary to fill the appropriate entry of the
    --  dispatch table of Prim's controlling type with Prim's address.
 
+   function Fill_Secondary_DT_Entry
+     (Loc          : Source_Ptr;
+      Prim         : Entity_Id;
+      Thunk_Id     : Entity_Id;
+      Iface_DT_Ptr : Entity_Id) return Node_Id;
+   --  (Ada 2005): Generate the code necessary to fill the appropriate entry of
+   --  the secondary dispatch table of Prim's controlling type with Thunk_Id's
+   --  address.
+
    procedure Make_Abstract_Interface_DT
      (AI_Tag          : Entity_Id;
       Acc_Disp_Tables : in out Elist_Id;
@@ -102,9 +110,10 @@ package Exp_Disp is
    --  secondary dispatch table
 
    function Expand_Interface_Thunk
-     (N         : Node_Id;
-      Thunk_Id  : Entity_Id;
-      Iface_Tag : Entity_Id) return Node_Id;
+     (N           : Node_Id;
+      Thunk_Alias : Node_Id;
+      Thunk_Id    : Entity_Id;
+      Iface_Tag   : Entity_Id) return Node_Id;
    --  Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
    --  generate additional subprograms (thunks) to have a layout compatible
    --  with the C++ ABI. The thunk modifies the value of the first actual of

gcc/ada/exp_util.adb

@@ -108,15 +108,6 @@ package body Exp_Util is
    --  procedure of record with task components, or for a dynamically
    --  created task that is assigned to a selected component.
 
-   procedure Find_Interface_Tag
-     (T         : Entity_Id;
-      Iface     : Entity_Id;
-      Iface_Tag : out Entity_Id;
-      Iface_ADT : out Entity_Id);
-   --  Ada 2005 (AI-251): Subsidiary procedure to Find_Interface_ADT and
-   --  Find_Interface_Tag. Given a type T implementing the interface,
-   --  returns the corresponding Tag and Access_Disp_Table entities.
-
    function Make_CW_Equivalent_Type
      (T : Entity_Id;
       E : Node_Id) return Entity_Id;
@@ -1298,26 +1289,100 @@ package body Exp_Util is
    -- Find_Interface_Tag --
    ------------------------
 
-   procedure Find_Interface_Tag
-     (T         : Entity_Id;
-      Iface     : Entity_Id;
-      Iface_Tag : out Entity_Id;
-      Iface_ADT : out Entity_Id)
+   function Find_Interface_ADT
+     (T     : Entity_Id;
+      Iface : Entity_Id) return Entity_Id
+   is
+      ADT   : Elmt_Id;
+      Found : Boolean := False;
+      Typ   : Entity_Id := T;
+
+      procedure Find_Secondary_Table (Typ : Entity_Id);
+      --  Comment required ???
+
+      --------------------------
+      -- Find_Secondary_Table --
+      --------------------------
+
+      procedure Find_Secondary_Table (Typ : Entity_Id) is
+         AI_Elmt : Elmt_Id;
+         AI      : Node_Id;
+
+      begin
+         if Etype (Typ) /= Typ then
+            Find_Secondary_Table (Etype (Typ));
+         end if;
+
+         if Present (Abstract_Interfaces (Typ))
+           and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
+         then
+            AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+            while Present (AI_Elmt) loop
+               AI := Node (AI_Elmt);
+
+               if AI = Iface or else Is_Ancestor (Iface, AI) then
+                  Found := True;
+                  return;
+               end if;
+
+               Next_Elmt (ADT);
+               Next_Elmt (AI_Elmt);
+            end loop;
+         end if;
+      end Find_Secondary_Table;
+
+   --  Start of processing for Find_Interface_Tag
+
+   begin
+      --  Handle private types
+
+      if Has_Private_Declaration (Typ)
+        and then Present (Full_View (Typ))
+      then
+         Typ := Full_View (Typ);
+      end if;
+
+      --  Handle access types
+
+      if Is_Access_Type (Typ) then
+         Typ := Directly_Designated_Type (Typ);
+      end if;
+
+      --  Handle task and protected types implementing interfaces
+
+      if Ekind (Typ) = E_Protected_Type
+        or else Ekind (Typ) = E_Task_Type
+      then
+         Typ := Corresponding_Record_Type (Typ);
+      end if;
+
+      ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+      pragma Assert (Present (Node (ADT)));
+      Find_Secondary_Table (Typ);
+      pragma Assert (Found);
+      return Node (ADT);
+   end Find_Interface_ADT;
+
+   ------------------------
+   -- Find_Interface_Tag --
+   ------------------------
+
+   function Find_Interface_Tag
+     (T      : Entity_Id;
+      Iface  : Entity_Id) return Entity_Id
    is
-      AI_Tag   : Entity_Id;
-      ADT_Elmt : Elmt_Id;
-      Found    : Boolean   := False;
+      AI_Tag : Entity_Id;
+      Found  : Boolean := False;
+      Typ    : Entity_Id := T;
 
-      procedure Find_AI_Tag (Typ : in Entity_Id; Found : in out Boolean);
-      --  This must be commented ???
+      procedure Find_Tag (Typ : in Entity_Id);
+      --  Internal subprogram used to recursively climb to the ancestors
 
       -----------------
       -- Find_AI_Tag --
       -----------------
 
-      procedure Find_AI_Tag (Typ : in Entity_Id; Found : in out Boolean) is
-         T       : Entity_Id := Typ;
-         Etyp    : Entity_Id; -- := Etype (Typ); -- why is this commented ???
+      procedure Find_Tag (Typ : in Entity_Id) is
          AI_Elmt : Elmt_Id;
          AI      : Node_Id;
 
@@ -1326,60 +1391,31 @@ package body Exp_Util is
          --  therefore shares the main tag.
 
          if Typ = Iface then
-            AI_Tag    := First_Tag_Component (Typ);
-            ADT_Elmt  := First_Elmt (Access_Disp_Table (Typ));
-            Found     := True;
+            pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+            AI_Tag := First_Tag_Component (Typ);
+            Found  := True;
             return;
          end if;
 
-         --  Handle private types
-
-         if Has_Private_Declaration (T)
-           and then Present (Full_View (T))
-         then
-            T := Full_View (T);
-         end if;
-
-         if Is_Access_Type (Typ) then
-            T := Directly_Designated_Type (T);
-
-         elsif Ekind (T) = E_Protected_Type
-           or else Ekind (T) = E_Task_Type
-         then
-            T := Corresponding_Record_Type (T);
-         end if;
-
-         Etyp := Etype (T);
-
          --  Climb to the root type
 
-         if Etyp /= Typ then
-            Find_AI_Tag (Etyp, Found);
+         if Etype (Typ) /= Typ then
+            Find_Tag (Etype (Typ));
          end if;
 
          --  Traverse the list of interfaces implemented by the type
 
          if not Found
-           and then Present (Abstract_Interfaces (T))
-           and then not Is_Empty_Elmt_List (Abstract_Interfaces (T))
+           and then Present (Abstract_Interfaces (Typ))
+           and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
          then
-            --  Skip the tag associated with the primary table (if
-            --  already placed in the record)
-
-            if Etype (Node (First_Elmt
-                              (Access_Disp_Table (T)))) = RTE (RE_Tag)
-            then
-               AI_Tag   := Next_Tag_Component (First_Tag_Component (T));
-               ADT_Elmt := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
-            else
-               AI_Tag   := First_Tag_Component (T);
-               ADT_Elmt := First_Elmt (Access_Disp_Table (T));
-            end if;
+            --  Skip the tag associated with the primary table.
 
+            pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+            AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
             pragma Assert (Present (AI_Tag));
-            pragma Assert (Present (Node (ADT_Elmt)));
 
-            AI_Elmt  := First_Elmt (Abstract_Interfaces (T));
+            AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
             while Present (AI_Elmt) loop
                AI := Node (AI_Elmt);
 
@@ -1390,47 +1426,38 @@ package body Exp_Util is
 
                AI_Tag := Next_Tag_Component (AI_Tag);
                Next_Elmt (AI_Elmt);
-               Next_Elmt (ADT_Elmt);
             end loop;
          end if;
-      end Find_AI_Tag;
+      end Find_Tag;
+
+   --  Start of processing for Find_Interface_Tag
 
    begin
-      Find_AI_Tag (T, Found);
-      pragma Assert (Found);
+      --  Handle private types
 
-      Iface_Tag := AI_Tag;
-      Iface_ADT := Node (ADT_Elmt);
-   end Find_Interface_Tag;
+      if Has_Private_Declaration (Typ)
+        and then Present (Full_View (Typ))
+      then
+         Typ := Full_View (Typ);
+      end if;
 
-   ------------------------
-   -- Find_Interface_Tag --
-   ------------------------
+      --  Handle access types
 
-   function Find_Interface_ADT
-     (T     : Entity_Id;
-      Iface : Entity_Id) return Entity_Id
-   is
-      Iface_Tag : Entity_Id := Empty;
-      Iface_ADT : Entity_Id := Empty;
-   begin
-      Find_Interface_Tag (T, Iface, Iface_Tag, Iface_ADT);
-      return Iface_ADT;
-   end Find_Interface_ADT;
+      if Is_Access_Type (Typ) then
+         Typ := Directly_Designated_Type (Typ);
+      end if;
 
-   ------------------------
-   -- Find_Interface_Tag --
-   ------------------------
+      --  Handle task and protected types implementing interfaces
 
-   function Find_Interface_Tag
-     (T     : Entity_Id;
-      Iface : Entity_Id) return Entity_Id
-   is
-      Iface_Tag : Entity_Id := Empty;
-      Iface_ADT : Entity_Id := Empty;
-   begin
-      Find_Interface_Tag (T, Iface, Iface_Tag, Iface_ADT);
-      return Iface_Tag;
+      if Ekind (Typ) = E_Protected_Type
+        or else Ekind (Typ) = E_Task_Type
+      then
+         Typ := Corresponding_Record_Type (Typ);
+      end if;
+
+      Find_Tag (Typ);
+      pragma Assert (Found);
+      return AI_Tag;
    end Find_Interface_Tag;
 
    ------------------