exp_ch13.adb (Expand_External_Tag_Definition): Replace call to the run-time…

exp_ch13.adb (Expand_External_Tag_Definition): Replace call to the run-time subprogram Set_External_Tag by call to...

2007-04-06  Javier Miranda  <miranda@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* exp_ch13.adb (Expand_External_Tag_Definition): Replace call to the
	run-time subprogram Set_External_Tag by call to Build_Set_External_Tag.

	* exp_ch4.adb (Expand_Allocator_Expression): Don't perform a run-time
	accessibility on class-wide allocators if the allocator occurs at the
	same scope level as the allocator's type. The check is guaranteed to
	succeed in that case, even when the expression originates from a
	parameter of the containing subprogram.
	(Expand_N_Op_Eq): Do nothing in case of dispatching call if compiling
	under No_Dispatching_Calls restriction. During the semantic analysis
	we already notified such violation.
	(Tagged_Membership): Constant folding. There is no need to check
	the tag at run-time if the type of the right operand is non
	class-wide abstract.
	Replace call to Is_Ancestor by call to Is_Parent
	to support concurrent types with interface types.
	(Expand_N_Allocator): Add an assertion associated with the generation
	of the master_id.
	(Expand_N_Slice): Do not enable range check to nodes associated
	with the frontend expansion of the dispatch table.
	(Is_Local_Access_Discriminant): Subsidiary function to
	Expand_N_Allocator.
	(Tagged_Membership): Replace generation of call to the run-time
	subprogram CW_Membership by call to Build_CW_Membership.
	(Expand_Allocator_Expression): Replace generation of call to the
	run-time subprogram Get_Access_Level by call to Build_Get_Access_Level.

	* exp_disp.ads, exp_disp.adb (Make_DT): Code reorganization to
	initialize most the TSD components by means of an aggregate.
	Modify the declaration of the object containing the TSD
	because we now expand code that has a higher level of abstraction.
	The TSD has a discriminant containing the Inheritance Depth Level,
	value that is used in the membership test but also to fix the size
	of the table of ancestors.
	(Expand_Interface_Conversion): Insert function body at the closest place
	to the conversion expression, to prevent access-before-elaboration
	errors in the backend.
	Code improved to reduce the size of the dispatch table if
	compiling under restriction No_Dispatching_Calls plus code cleanup.
	Code reorganization plus removal of calls to Set_Num_Prim_Ops
	(Make_Secondary_DT): Remove call to Set_Num_Prim_Ops.
	(Expand_Dispatching_Call): Minor code reorganization plus addition of
	code to return immediately if compiling under No_Dispatching_Calls
	restriction.
	(Set_All_DT_Position): Remove code associated with the old CPP pragmas.
	CPP_Virtual and CPP_Vtable are no longer supported.
	(Expand_Interface_Conversion): Add missing support for interface type
	derivations.
	(Expand_Interface_Actuals): Replace calls to Is_Ancestor by calls to
	Is_Parent to support concurrent types with interfaces.
	(Init_Predefined_Interface_Primitives): Removed.
	(Make_Secondary_DT): Modified to support concurrent record types.
	(Set_All_DT_Position): Modified to support concurrent record types.
	(Ada_Actions, Action_Is_Proc, Action_Nb_Arg): Remove entries associated
	with Get_External_Tag, Inherit_TSD, Set_External_Tag.
	(Ada_Actions, Action_Is_Proc, Action_Nb_Arg): Remove entry associated
	with CW_Membership.
	(Ada_Actions, Action_Is_Proc, Action_Nb_Arg): Remove entries associated
	with Get_Access_Level, Get_Predefined_Prim_Op_Address,
	Get_Prim_Op_Address Get_RC_Offset, Get_Remotely_Callable, Inherit_DT,
	Set_Access_Level, Set_Expanded_Name, Set_Predefined_Prim_Op_Address,
	Set_Prim_Op_Address, Set_RC_Offset, Set_Remotely_Callable, Set_TSD.
	(Expand_Dispatching_Call): Replace generation of call to the run-time
	subprograms Get_Predefined_Prim_Op_Address and Get_Prim_Op_Address by
	calls to Build_Get_Predefined_Prim_Op_Address, and Build_Get_Prim_Op_
	Address.
	(Fill_DT_Entry, Fill_Secondary_DT_Entry): Replace generation of call to
	the run-time subprograms Set_Predefined_Prim_Op_Address and Set_Prim_
	Op_Address by calls to Build_Set_Predefined_Prim_Op_Address, and
	Build_Set_Prim_Op_Address.
	(Get_Remotely_Callable): Subprogram removed.
	(Init_Predefined_Interface_Primitives): Replace generation of call to
	the run-time subprograms Inherit_DT by call to Build_Inherit_Predefined_
	Prims.

	* sem_elab.adb (Set_Elaboration_Constraint): Replace the call to
	First (Parameter_Associations ()) with the call to First_Actual that
	returns an actual parameter expression for both named and positional
	associations.

	* sem_disp.adb (Check_Dispatching_Call): In case of dispatching call
	check violation of restriction No_Dispatching_Calls.
	(Check_Controlling_Type): A formal of a tagged incomplete type is a
	controlling argument.

	* exp_util.ads, exp_util.adb (Type_May_Have_Bit_Aligned_Components): Use
	First/Next_Component_Or_Discriminant
	(Insert_Actions): Add entries for new N_Push and N_Pop nodes
	(Find_Implemented_Interface): Removed. All the calls to this subprogram
	specify Any_Limited_Interface, and this functionality is already
	provided by the function Has_Abstract_Interfaces.
	(Find_Interface, Find_Interface_Tag, Find_Interface_ADT): Modified to
	support concurrent types implementing interfaces.
	(Find_Implemented_Interface): Removed. All the calls to this subprogram
	specify kind Any_Limited_Interface, and this functionality is already
	provided by the function Has_Abstract_Interfaces.
	(Remove_Side_Effects): replace Controlled_Type by
	CW_Or_Controlled_Type whenever the issue is related to
	using or not the secondary stack.

	* par-ch12.adb (P_Formal_Type_Definition): Update calls to
	P_Interface_Type_Definition to fulfill the new interface (the formal
	Is_Synchronized is no longer required).

	* Make-lang.in (GNAT_ADA_OBJS): Addition of exp_atag.o
	Update dependencies.

	* exp_atag.ads, exp_atag.adb: New file

From-SVN: r123562

gcc/ada/exp_atag.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             E X P _ A T A G                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--            Copyright (C) 2006, 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- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
+-- Boston, MA 02110-1301, USA.                                              --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Atree;    use Atree;
+with Einfo;    use Einfo;
+with Exp_Util; use Exp_Util;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Rtsfind;  use Rtsfind;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Tbuild;   use Tbuild;
+with Uintp;    use Uintp;
+
+package body Exp_Atag is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   function Build_Predefined_DT
+     (Loc      : Source_Ptr;
+      Tag_Node : Node_Id) return Node_Id;
+   --  Build code that displaces the Tag to reference the dispatch table
+   --  containing the predefined primitives.
+   --
+   --  Generates: To_Tag (To_Address (Tag_Node) - DT_Prologue_Size);
+   pragma Inline (Build_Predefined_DT);
+
+   function Build_Typeinfo_Offset (Loc : Source_Ptr) return Node_Id;
+   --  Build code that gives access to the distance from the tag to the
+   --  Typeinfo component of the dispatch table.
+   --
+   --  Generates: DT_Typeinfo_Ptr_Size
+   pragma Inline (Build_Typeinfo_Offset);
+
+   function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id;
+   --  Build code that retrieves the address of the record containing the Type
+   --  Specific Data generated by GNAT.
+   --
+   --  Generate: To_Type_Specific_Data_Ptr
+   --              (To_Address_Ptr (To_Address (Tag) - Typeinfo_Offset).all);
+   pragma Inline (Build_TSD);
+
+   function RTE_Tag_Node return Entity_Id;
+   --  Returns the entity associated with Ada.Tags.Tag
+   pragma Inline (RTE_Tag_Node);
+
+   -------------------------
+   -- Build_CW_Membership --
+   -------------------------
+
+   function Build_CW_Membership
+     (Loc          : Source_Ptr;
+      Obj_Tag_Node : Node_Id;
+      Typ_Tag_Node : Node_Id) return Node_Id
+   is
+      function Build_Pos return Node_Id;
+      --  Generate TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
+
+      function Build_Pos return Node_Id is
+      begin
+         return
+            Make_Op_Subtract (Loc,
+              Left_Opnd =>
+                Make_Selected_Component (Loc,
+                  Prefix => Build_TSD (Loc, Duplicate_Subexpr (Obj_Tag_Node)),
+                  Selector_Name =>
+                    New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)),
+
+              Right_Opnd =>
+                Make_Selected_Component (Loc,
+                  Prefix => Build_TSD (Loc, Duplicate_Subexpr (Typ_Tag_Node)),
+                  Selector_Name =>
+                    New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)));
+      end Build_Pos;
+
+   --  Start of processing for Build_CW_Membership
+
+   begin
+      return
+        Make_And_Then (Loc,
+           Left_Opnd =>
+             Make_Op_Ge (Loc,
+               Left_Opnd  => Build_Pos,
+               Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
+
+           Right_Opnd =>
+             Make_Op_Eq (Loc,
+               Left_Opnd =>
+                 Make_Indexed_Component (Loc,
+                   Prefix =>
+                     Make_Selected_Component (Loc,
+                       Prefix => Build_TSD (Loc, Obj_Tag_Node),
+                       Selector_Name =>
+                         New_Reference_To
+                           (RTE_Record_Component (RE_Tags_Table), Loc)),
+                   Expressions =>
+                     New_List (Build_Pos)),
+
+               Right_Opnd => Typ_Tag_Node));
+   end Build_CW_Membership;
+
+   ----------------------------
+   -- Build_Get_Access_Level --
+   ----------------------------
+
+   function Build_Get_Access_Level
+     (Loc      : Source_Ptr;
+      Tag_Node : Node_Id) return Node_Id
+   is
+   begin
+      return
+        Make_Selected_Component (Loc,
+          Prefix => Build_TSD (Loc, Tag_Node),
+          Selector_Name =>
+            New_Reference_To
+              (RTE_Record_Component (RE_Access_Level), Loc));
+   end Build_Get_Access_Level;
+
+   ------------------------------------------
+   -- Build_Get_Predefined_Prim_Op_Address --
+   ------------------------------------------
+
+   function Build_Get_Predefined_Prim_Op_Address
+     (Loc           : Source_Ptr;
+      Tag_Node      : Node_Id;
+      Position_Node : Node_Id) return Node_Id
+   is
+   begin
+      return
+         Make_Indexed_Component (Loc,
+           Prefix =>
+             Make_Selected_Component (Loc,
+               Prefix =>
+                 Build_Predefined_DT (Loc, Tag_Node),
+
+               Selector_Name =>
+                 New_Reference_To
+                   (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+
+           Expressions =>
+             New_List (Position_Node));
+   end Build_Get_Predefined_Prim_Op_Address;
+
+   -------------------------------
+   -- Build_Get_Prim_Op_Address --
+   -------------------------------
+
+   function Build_Get_Prim_Op_Address
+     (Loc           : Source_Ptr;
+      Tag_Node      : Node_Id;
+      Position_Node : Node_Id) return Node_Id
+   is
+   begin
+      return
+        Make_Indexed_Component (Loc,
+          Prefix =>
+            Make_Selected_Component (Loc,
+              Prefix =>
+                Unchecked_Convert_To
+                  (RTE_Tag_Node, Tag_Node),
+              Selector_Name =>
+                New_Reference_To
+                  (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+
+          Expressions => New_List (Position_Node));
+   end Build_Get_Prim_Op_Address;
+
+   -------------------------
+   -- Build_Get_RC_Offset --
+   -------------------------
+
+   function Build_Get_RC_Offset
+     (Loc      : Source_Ptr;
+      Tag_Node : Node_Id) return Node_Id
+   is
+   begin
+      return
+        Make_Selected_Component (Loc,
+          Prefix => Build_TSD (Loc, Tag_Node),
+          Selector_Name =>
+            New_Reference_To
+              (RTE_Record_Component (RE_RC_Offset), Loc));
+   end Build_Get_RC_Offset;
+
+   ---------------------------------
+   -- Build_Get_Remotely_Callable --
+   ---------------------------------
+
+   function Build_Get_Remotely_Callable
+     (Loc      : Source_Ptr;
+      Tag_Node : Node_Id) return Node_Id
+   is
+   begin
+      return
+        Make_Selected_Component (Loc,
+          Prefix => Build_TSD (Loc, Tag_Node),
+          Selector_Name =>
+            New_Reference_To
+              (RTE_Record_Component (RE_Remotely_Callable), Loc));
+   end Build_Get_Remotely_Callable;
+
+   ------------------------------------
+   -- Build_Inherit_Predefined_Prims --
+   ------------------------------------
+
+   function Build_Inherit_Predefined_Prims
+     (Loc          : Source_Ptr;
+      Old_Tag_Node : Node_Id;
+      New_Tag_Node : Node_Id) return Node_Id
+   is
+   begin
+      return
+        Make_Assignment_Statement (Loc,
+          Name =>
+            Make_Slice (Loc,
+              Prefix =>
+                Make_Selected_Component (Loc,
+                  Prefix =>
+                    Build_Predefined_DT (Loc, New_Tag_Node),
+                  Selector_Name =>
+                    New_Reference_To
+                      (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+
+              Discrete_Range => Make_Range (Loc,
+                Make_Integer_Literal (Loc, Uint_1),
+                New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))),
+
+          Expression =>
+            Make_Slice (Loc,
+              Prefix =>
+                Make_Selected_Component (Loc,
+                  Prefix        => Build_Predefined_DT (Loc, Old_Tag_Node),
+                  Selector_Name =>
+                    New_Reference_To
+                      (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+              Discrete_Range =>
+                Make_Range (Loc,
+                  Low_Bound  => Make_Integer_Literal (Loc, 1),
+                  High_Bound =>
+                    New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))));
+
+   end Build_Inherit_Predefined_Prims;
+
+   -------------------------
+   -- Build_Inherit_Prims --
+   -------------------------
+
+   function Build_Inherit_Prims
+     (Loc          : Source_Ptr;
+      Old_Tag_Node : Node_Id;
+      New_Tag_Node : Node_Id;
+      Num_Prims    : Nat) return Node_Id
+   is
+   begin
+      return
+        Make_Assignment_Statement (Loc,
+          Name =>
+            Make_Slice (Loc,
+              Prefix =>
+                Make_Selected_Component (Loc,
+                  Prefix =>
+                    Unchecked_Convert_To (RTE_Tag_Node, New_Tag_Node),
+                  Selector_Name =>
+                    New_Reference_To
+                      (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+              Discrete_Range =>
+                Make_Range (Loc,
+                Low_Bound  => Make_Integer_Literal (Loc, 1),
+                High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
+
+          Expression =>
+            Make_Slice (Loc,
+              Prefix =>
+                Make_Selected_Component (Loc,
+                  Prefix =>
+                    Unchecked_Convert_To (RTE_Tag_Node, Old_Tag_Node),
+                  Selector_Name =>
+                    New_Reference_To
+                      (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+              Discrete_Range =>
+                Make_Range (Loc,
+                Low_Bound  => Make_Integer_Literal (Loc, 1),
+                High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
+   end Build_Inherit_Prims;
+
+   -------------------
+   -- Build_New_TSD --
+   -------------------
+
+   function Build_New_TSD
+     (Loc          : Source_Ptr;
+      New_Tag_Node : Node_Id) return List_Id
+   is
+   begin
+      return New_List (
+         Make_Assignment_Statement (Loc,
+           Name =>
+             Make_Indexed_Component (Loc,
+               Prefix =>
+                 Make_Selected_Component (Loc,
+                   Prefix => Build_TSD (Loc, Duplicate_Subexpr (New_Tag_Node)),
+                   Selector_Name =>
+                     New_Reference_To
+                       (RTE_Record_Component (RE_Tags_Table), Loc)),
+               Expressions => New_List (Make_Integer_Literal (Loc, Uint_0))),
+
+           Expression => New_Tag_Node));
+   end Build_New_TSD;
+
+   -----------------------
+   -- Build_Inherit_TSD --
+   -----------------------
+
+   function Build_Inherit_TSD
+     (Loc               : Source_Ptr;
+      Old_Tag_Node      : Node_Id;
+      New_Tag_Node      : Node_Id;
+      I_Depth           : Nat;
+      Parent_Num_Ifaces : Nat) return Node_Id
+   is
+      function Build_Iface_Table_Ptr (Tag_Node : Node_Id) return Node_Id;
+      --  Generates: Interface_Data_Ptr! (TSD (Tag).Ifaces_Table_Ptr).all
+
+      ----------------------------
+      --  Build_Iface_Table_Ptr --
+      ----------------------------
+
+      function Build_Iface_Table_Ptr (Tag_Node : Node_Id) return Node_Id is
+      begin
+         return
+            Unchecked_Convert_To (RTE (RE_Interface_Data_Ptr),
+              Make_Selected_Component (Loc,
+                Prefix => Tag_Node,
+                Selector_Name =>
+                  New_Reference_To
+                    (RTE_Record_Component (RE_Ifaces_Table_Ptr), Loc)));
+      end Build_Iface_Table_Ptr;
+
+      --  Local variables
+
+      L       : constant List_Id := New_List;
+      Old_TSD : Node_Id;
+      New_TSD : Node_Id;
+
+   --  Start of processing for Build_Inherit_TSD
+
+   begin
+      Old_TSD :=
+        Make_Object_Declaration (Loc,
+          Defining_Identifier =>
+            Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
+          Object_Definition =>
+            New_Reference_To (RTE (RE_Type_Specific_Data_Ptr), Loc),
+          Expression =>
+            Build_TSD (Loc, Duplicate_Subexpr (Old_Tag_Node)));
+
+      New_TSD :=
+        Make_Object_Declaration (Loc,
+          Defining_Identifier =>
+            Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
+          Object_Definition =>
+            New_Reference_To (RTE (RE_Type_Specific_Data_Ptr), Loc),
+          Expression =>
+            Build_TSD (Loc, Duplicate_Subexpr (New_Tag_Node)));
+
+      Append_List_To (L, New_List (
+
+         --  Copy the table of ancestors of the parent
+         --    TSD (New_Tag).Tags_Table (1 .. I_Depth) :=
+         --      TSD (Old_Tag).Tags_Table (0 .. I_Depth - 1);
+
+         Make_Assignment_Statement (Loc,
+           Name =>
+             Make_Slice (Loc,
+               Prefix =>
+                 Make_Selected_Component (Loc,
+                   Prefix =>
+                     Make_Explicit_Dereference (Loc,
+                       New_Reference_To (Defining_Identifier (New_TSD), Loc)),
+                   Selector_Name =>
+                     New_Reference_To
+                       (RTE_Record_Component (RE_Tags_Table), Loc)),
+               Discrete_Range => Make_Range (Loc,
+                 Make_Integer_Literal (Loc, Uint_1),
+                 Make_Integer_Literal (Loc, I_Depth))),
+
+           Expression =>
+             Make_Slice (Loc,
+               Prefix =>
+                 Make_Selected_Component (Loc,
+                   Prefix =>
+                     Make_Explicit_Dereference (Loc,
+                       New_Reference_To (Defining_Identifier (Old_TSD), Loc)),
+                   Selector_Name =>
+                     New_Reference_To
+                       (RTE_Record_Component (RE_Tags_Table), Loc)),
+               Discrete_Range => Make_Range (Loc,
+                 Make_Integer_Literal (Loc, Uint_0),
+                 Make_Integer_Literal (Loc, I_Depth - 1))))));
+
+         --  Copy the table of interfaces of the parent
+
+         --  if not System."=" (TSD (Old_Tag).Ifaces_Table_Ptr,
+         --                       System.Null_Address)
+         --  then
+         --     New_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces):=
+         --       Old_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces);
+         --  end if;
+
+         --  The table of interfaces is not available under certified run-time
+
+         if RTE_Record_Component_Available (RE_Nb_Ifaces) then
+            Append_To (L,
+              Make_If_Statement (Loc,
+                Condition =>
+                  Make_Op_Not (Loc,
+                    Right_Opnd =>
+                      Make_Op_Eq (Loc,
+                        Left_Opnd =>
+                          Make_Selected_Component (Loc,
+                            Prefix =>
+                              Make_Explicit_Dereference (Loc,
+                                New_Reference_To
+                                  (Defining_Identifier (Old_TSD), Loc)),
+                            Selector_Name =>
+                              New_Reference_To
+                                (RTE_Record_Component (RE_Ifaces_Table_Ptr),
+                                 Loc)),
+                        Right_Opnd =>
+                          New_Reference_To (RTE (RE_Null_Address), Loc))),
+
+                Then_Statements => New_List (
+                  Make_Assignment_Statement (Loc,
+                    Name =>
+                      Make_Slice (Loc,
+                        Prefix =>
+                          Make_Selected_Component (Loc,
+                            Prefix =>
+                              Build_Iface_Table_Ptr
+                                (New_Reference_To
+                                  (Defining_Identifier (New_TSD), Loc)),
+                            Selector_Name =>
+                              New_Reference_To
+                                (RTE_Record_Component (RE_Ifaces_Table), Loc)),
+
+                        Discrete_Range => Make_Range (Loc,
+                          Make_Integer_Literal (Loc, Uint_1),
+                          Make_Integer_Literal (Loc, Parent_Num_Ifaces))),
+
+                    Expression =>
+                      Make_Slice (Loc,
+                        Prefix =>
+                          Make_Selected_Component (Loc,
+                            Prefix =>
+                              Build_Iface_Table_Ptr
+                                (New_Reference_To
+                                  (Defining_Identifier (Old_TSD), Loc)),
+                            Selector_Name =>
+                              New_Reference_To
+                                (RTE_Record_Component (RE_Ifaces_Table), Loc)),
+
+                        Discrete_Range => Make_Range (Loc,
+                          Make_Integer_Literal (Loc, Uint_1),
+                          Make_Integer_Literal (Loc, Parent_Num_Ifaces)))))));
+         end if;
+
+         --  TSD (New_Tag).Tags_Table (0) := New_Tag;
+
+         Append_To (L,
+            Make_Assignment_Statement (Loc,
+              Name =>
+                Make_Indexed_Component (Loc,
+                  Prefix =>
+                    Make_Selected_Component (Loc,
+                      Prefix =>
+                        Make_Explicit_Dereference (Loc,
+                          New_Reference_To
+                            (Defining_Identifier (New_TSD), Loc)),
+                      Selector_Name =>
+                        New_Reference_To
+                          (RTE_Record_Component (RE_Tags_Table), Loc)),
+                  Expressions =>
+                    New_List (Make_Integer_Literal (Loc, Uint_0))),
+
+              Expression => New_Tag_Node));
+
+      return
+        Make_Block_Statement (Loc,
+          Declarations => New_List (
+            Old_TSD,
+            New_TSD),
+          Handled_Statement_Sequence =>
+            Make_Handled_Sequence_Of_Statements (Loc, L));
+
+   end Build_Inherit_TSD;
+
+   -------------------------
+   -- Build_Predefined_DT --
+   -------------------------
+
+   function Build_Predefined_DT
+     (Loc      : Source_Ptr;
+      Tag_Node : Node_Id) return Node_Id
+   is
+   begin
+      return
+        Unchecked_Convert_To (RTE_Tag_Node,
+          Make_Function_Call (Loc,
+            Name =>
+              Make_Expanded_Name (Loc,
+                Chars         => Name_Op_Subtract,
+                Prefix        =>
+                  New_Reference_To (RTU_Entity (System_Storage_Elements), Loc),
+                Selector_Name =>
+                  Make_Identifier (Loc,
+                    Chars => Name_Op_Subtract)),
+
+            Parameter_Associations => New_List (
+              Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
+              New_Reference_To (RTE (RE_DT_Prologue_Size), Loc))));
+   end Build_Predefined_DT;
+
+   ----------------------------
+   -- Build_Set_External_Tag --
+   ----------------------------
+
+   function Build_Set_External_Tag
+     (Loc        : Source_Ptr;
+      Tag_Node   : Node_Id;
+      Value_Node : Node_Id) return Node_Id
+   is
+   begin
+      return
+         Make_Assignment_Statement (Loc,
+           Name =>
+             Make_Selected_Component (Loc,
+               Prefix => Build_TSD (Loc, Tag_Node),
+               Selector_Name =>
+                 New_Reference_To
+                   (RTE_Record_Component (RO_TA_External_Tag), Loc)),
+
+           Expression =>
+             Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Value_Node));
+   end Build_Set_External_Tag;
+
+   ------------------------------------------
+   -- Build_Set_Predefined_Prim_Op_Address --
+   ------------------------------------------
+
+   function Build_Set_Predefined_Prim_Op_Address
+     (Loc           : Source_Ptr;
+      Tag_Node      : Node_Id;
+      Position_Node : Node_Id;
+      Address_Node  : Node_Id) return Node_Id
+   is
+   begin
+      return
+         Make_Assignment_Statement (Loc,
+           Name       => Build_Get_Predefined_Prim_Op_Address
+                          (Loc, Tag_Node, Position_Node),
+           Expression => Address_Node);
+   end Build_Set_Predefined_Prim_Op_Address;
+
+   -------------------------------
+   -- Build_Set_Prim_Op_Address --
+   -------------------------------
+
+   function Build_Set_Prim_Op_Address
+     (Loc           : Source_Ptr;
+      Tag_Node      : Node_Id;
+      Position_Node : Node_Id;
+      Address_Node  : Node_Id) return Node_Id
+   is
+   begin
+      return
+         Make_Assignment_Statement (Loc,
+           Name       => Build_Get_Prim_Op_Address (Loc,
+                           Tag_Node, Position_Node),
+           Expression => Address_Node);
+   end Build_Set_Prim_Op_Address;
+
+   -------------------
+   -- Build_Set_TSD --
+   -------------------
+
+   function Build_Set_TSD
+     (Loc        : Source_Ptr;
+      Tag_Node   : Node_Id;
+      Value_Node : Node_Id) return Node_Id
+   is
+   begin
+      return
+         Make_Assignment_Statement (Loc,
+           Name =>
+             Make_Explicit_Dereference (Loc,
+               Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
+                   Make_Function_Call (Loc,
+                     Name =>
+                       Make_Expanded_Name (Loc,
+                         Chars => Name_Op_Subtract,
+                         Prefix =>
+                           New_Reference_To
+                             (RTU_Entity (System_Storage_Elements), Loc),
+                         Selector_Name =>
+                           Make_Identifier (Loc,
+                             Chars => Name_Op_Subtract)),
+
+                     Parameter_Associations => New_List (
+                       Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
+                       Build_Typeinfo_Offset (Loc))))),
+
+           Expression => Value_Node);
+   end Build_Set_TSD;
+
+   ---------------
+   -- Build_TSD --
+   ---------------
+
+   function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id is
+   begin
+      return
+        Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
+          Make_Explicit_Dereference (Loc,
+            Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
+                Make_Function_Call (Loc,
+                  Name =>
+                    Make_Expanded_Name (Loc,
+                      Chars => Name_Op_Subtract,
+                      Prefix =>
+                        New_Reference_To
+                          (RTU_Entity (System_Storage_Elements), Loc),
+                      Selector_Name =>
+                        Make_Identifier (Loc,
+                          Chars => Name_Op_Subtract)),
+
+                  Parameter_Associations => New_List (
+                    Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
+                    Build_Typeinfo_Offset (Loc))))));
+   end Build_TSD;
+
+   ---------------------------
+   -- Build_Typeinfo_Offset --
+   ---------------------------
+
+   function Build_Typeinfo_Offset (Loc : Source_Ptr) return Node_Id is
+   begin
+      return New_Reference_To (RTE (RE_DT_Typeinfo_Ptr_Size), Loc);
+   end Build_Typeinfo_Offset;
+
+   ---------------
+   --  Tag_Node --
+   ---------------
+
+   function RTE_Tag_Node return Entity_Id is
+      E : constant Entity_Id := RTE (RE_Tag);
+   begin
+      if Atree.Present (Full_View (E)) then
+         return Full_View (E);
+      else
+         return E;
+      end if;
+   end RTE_Tag_Node;
+end Exp_Atag;

gcc/ada/exp_atag.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             E X P _ A T A G                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--            Copyright (C) 2006, 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- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
+-- Boston, MA 02110-1301, USA.                                              --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package contains routines involved in the frontend expansion of
+--  subprograms of package Ada.Tags
+
+with Types; use Types;
+
+package Exp_Atag is
+
+   function Build_CW_Membership
+     (Loc          : Source_Ptr;
+      Obj_Tag_Node : Node_Id;
+      Typ_Tag_Node : Node_Id) return Node_Id;
+   --  Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each
+   --  dispatch table contains a reference to a table of ancestors (stored
+   --  in the first part of the Tags_Table) and a count of the level of
+   --  inheritance "Idepth". Obj is in Typ'Class if Typ'Tag is in the table
+   --  of ancestors that are contained in the dispatch table referenced by
+   --  Obj'Tag. Knowing the level of inheritance of both types, this can be
+   --  computed in constant time by the formula:
+   --
+   --   TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
+   --     = Typ'tag
+
+   function Build_Get_Access_Level
+     (Loc      : Source_Ptr;
+      Tag_Node : Node_Id) return Node_Id;
+   --  Build code that retrieves the accessibility level of the tagged type.
+   --
+   --  Generates: TSD (Tag).Access_Level
+
+   function Build_Get_Predefined_Prim_Op_Address
+     (Loc           : Source_Ptr;
+      Tag_Node      : Node_Id;
+      Position_Node : Node_Id) return Node_Id;
+   --  Given a pointer to a dispatch table (T) and a position in the DT, build
+   --  code that gets the address of the predefined virtual function stored in
+   --  it (used for dispatching calls).
+   --
+   --  Generates: Predefined_DT (Tag).D (Position);
+
+   function Build_Get_Prim_Op_Address
+     (Loc           : Source_Ptr;
+      Tag_Node      : Node_Id;
+      Position_Node : Node_Id) return Node_Id;
+   --  Build code that retrieves the address of the virtual function stored in
+   --  a given position of the dispatch table (used for dispatching calls).
+   --
+   --  Generates: To_Tag (Tag).D (Position);
+
+   function Build_Get_RC_Offset
+     (Loc        : Source_Ptr;
+      Tag_Node   : Node_Id) return Node_Id;
+   --  Build code that retrieves the Offset of the implicit record controller
+   --  when the object has controlled components. O otherwise.
+   --
+   --  Generates: TSD (T).RC_Offset;
+
+   function Build_Get_Remotely_Callable
+     (Loc        : Source_Ptr;
+      Tag_Node   : Node_Id) return Node_Id;
+   --  Build code that retrieves the value previously saved by Set_Remotely
+   --  Callable
+   --
+   --  Generates: TSD (Tag).Remotely_Callable
+
+   function Build_Inherit_Predefined_Prims
+     (Loc              : Source_Ptr;
+      Old_Tag_Node     : Node_Id;
+      New_Tag_Node     : Node_Id) return Node_Id;
+   --  Build code that inherits the predefined primitives of the parent.
+   --
+   --  Generates: Predefined_DT (New_T).D (All_Predefined_Prims) :=
+   --               Predefined_DT (Old_T).D (All_Predefined_Prims);
+
+   function Build_Inherit_Prims
+     (Loc          : Source_Ptr;
+      Old_Tag_Node : Node_Id;
+      New_Tag_Node : Node_Id;
+      Num_Prims    : Nat) return Node_Id;
+   --  Build code that inherits Num_Prims user-defined primitives from the
+   --  dispatch table of the parent type.
+   --
+   --  Generates:
+   --    New_Tag.Prims_Ptr (1 .. Num_Prims) :=
+   --      Old_Tag.Prims_Ptr (1 .. Num_Prims);
+
+   function Build_Inherit_TSD
+     (Loc               : Source_Ptr;
+      Old_Tag_Node      : Node_Id;
+      New_Tag_Node      : Node_Id;
+      I_Depth           : Nat;
+      Parent_Num_Ifaces : Nat) return Node_Id;
+   --  Generates code that initializes the TSD of a type knowing the tag,
+   --  inheritance depth, and number of interface types of the parent type.
+   --
+   --  Generates:
+   --     --  Copy the table of ancestors of the parent
+   --
+   --     TSD (New_Tag).Tags_Table (1 .. I_Depth) :=
+   --       TSD (Old_Tag).Tags_Table (0 .. I_Depth - 1);
+   --
+   --     --  Copy the table of interfaces of the parent
+   --
+   --     if TSD (Old_Tag).Ifaces_Table_Ptr /= null then
+   --        New_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces):=
+   --          Old_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces);
+   --     end if;
+   --
+   --     TSD (New_Tag).Tags_Table (0) := New_Tag;
+
+   function Build_New_TSD
+     (Loc          : Source_Ptr;
+      New_Tag_Node : Node_Id) return List_Id;
+   --  Build code that initializes the TSD of a root type.
+   --  Generates: TSD (New_Tag).Tags_Table (0) := New_Tag;
+
+   function Build_Set_External_Tag
+     (Loc        : Source_Ptr;
+      Tag_Node   : Node_Id;
+      Value_Node : Node_Id) return Node_Id;
+   --  Build code that saves the address of the string containing the external
+   --  tag in the dispatch table.
+   --
+   --  Generates: TSD (Tag).External_Tag := Cstring_Ptr! (Value);
+
+   function Build_Set_Predefined_Prim_Op_Address
+     (Loc           : Source_Ptr;
+      Tag_Node      : Node_Id;
+      Position_Node : Node_Id;
+      Address_Node  : Node_Id) return Node_Id;
+   --  Build code that saves the address of a virtual function in a given
+   --  Position of the portion of the dispatch table associated with the
+   --  predefined primitives of Tag (used for overriding).
+   --
+   --  Generates: Predefined_DT (Tag).D (Position) := Value
+
+   function Build_Set_Prim_Op_Address
+     (Loc           : Source_Ptr;
+      Tag_Node      : Node_Id;
+      Position_Node : Node_Id;
+      Address_Node  : Node_Id) return Node_Id;
+   --  Build code that saves the address of a virtual function in a given
+   --  Position of the dispatch table associated with the Tag (used for
+   --  overriding).
+   --
+   --  Generates: Tag.D (Position) := Value
+
+   function Build_Set_TSD
+     (Loc        : Source_Ptr;
+      Tag_Node   : Node_Id;
+      Value_Node : Node_Id) return Node_Id;
+   --  Build code that saves the address of the record containing the Type
+   --  Specific Data generated by GNAT.
+   --
+   --  Generates: To_Addr_Ptr (To_Address (Tag) - K_Typeinfo).all := Value
+
+end Exp_Atag;

gcc/ada/exp_ch13.adb

@@ -27,6 +27,7 @@
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
+with Exp_Atag; use Exp_Atag;
 with Exp_Ch3;  use Exp_Ch3;
 with Exp_Ch6;  use Exp_Ch6;
 with Exp_Imgv; use Exp_Imgv;
@@ -211,16 +212,16 @@ package body Exp_Ch13 is
             Make_String_Literal (Loc, Strval => New_Val)));
 
       Append_Freeze_Actions (Ent, New_List (
-        Make_Procedure_Call_Statement (Loc,
-          Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc),
-          Parameter_Associations => New_List (
+
+        Build_Set_External_Tag (Loc,
+          Tag_Node =>
             Make_Attribute_Reference (Loc,
               Attribute_Name => Name_Tag,
               Prefix         => New_Occurrence_Of (Ent, Loc)),
-
+          Value_Node =>
             Make_Attribute_Reference (Loc,
               Attribute_Name => Name_Address,
-              Prefix         => New_Occurrence_Of (E, Loc)))),
+              Prefix         => New_Occurrence_Of (E, Loc))),
 
         Make_Procedure_Call_Statement (Loc,
           Name => New_Reference_To (RTE (RE_Register_Tag), Loc),

gcc/ada/exp_disp.adb

@@ -30,6 +30,7 @@ with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
+with Exp_Atag; use Exp_Atag;
 with Exp_Ch7;  use Exp_Ch7;
 with Exp_Dbug; use Exp_Dbug;
 with Exp_Tss;  use Exp_Tss;
@@ -154,10 +155,10 @@ package body Exp_Disp is
       ------------------------------------------------
 
       procedure Build_Common_Dispatching_Select_Statements
-        (Loc   : Source_Ptr;
-         Typ   : Entity_Id;
+        (Loc    : Source_Ptr;
+         Typ    : Entity_Id;
          DT_Ptr : Entity_Id;
-         Stmts : List_Id)
+         Stmts  : List_Id)
       is
       begin
          --  Generate:
@@ -305,115 +306,49 @@ package body Exp_Disp is
    package SEU renames Select_Expansion_Utilities;
 
    Ada_Actions : constant array (DT_Access_Action) of RE_Id :=
-      (CW_Membership                  => RE_CW_Membership,
-       IW_Membership                  => RE_IW_Membership,
-       DT_Entry_Size                  => RE_DT_Entry_Size,
-       DT_Prologue_Size               => RE_DT_Prologue_Size,
-       Get_Access_Level               => RE_Get_Access_Level,
+      (IW_Membership                  => RE_IW_Membership,
        Get_Entry_Index                => RE_Get_Entry_Index,
-       Get_External_Tag               => RE_Get_External_Tag,
-       Get_Predefined_Prim_Op_Address => RE_Get_Predefined_Prim_Op_Address,
-       Get_Prim_Op_Address            => RE_Get_Prim_Op_Address,
        Get_Prim_Op_Kind               => RE_Get_Prim_Op_Kind,
-       Get_RC_Offset                  => RE_Get_RC_Offset,
-       Get_Remotely_Callable          => RE_Get_Remotely_Callable,
        Get_Tagged_Kind                => RE_Get_Tagged_Kind,
-       Inherit_DT                     => RE_Inherit_DT,
-       Inherit_TSD                    => RE_Inherit_TSD,
        Register_Interface_Tag         => RE_Register_Interface_Tag,
        Register_Tag                   => RE_Register_Tag,
-       Set_Access_Level               => RE_Set_Access_Level,
        Set_Entry_Index                => RE_Set_Entry_Index,
-       Set_Expanded_Name              => RE_Set_Expanded_Name,
-       Set_External_Tag               => RE_Set_External_Tag,
-       Set_Interface_Table            => RE_Set_Interface_Table,
        Set_Offset_Index               => RE_Set_Offset_Index,
        Set_OSD                        => RE_Set_OSD,
-       Set_Predefined_Prim_Op_Address => RE_Set_Predefined_Prim_Op_Address,
-       Set_Prim_Op_Address            => RE_Set_Prim_Op_Address,
        Set_Prim_Op_Kind               => RE_Set_Prim_Op_Kind,
-       Set_RC_Offset                  => RE_Set_RC_Offset,
-       Set_Remotely_Callable          => RE_Set_Remotely_Callable,
        Set_Signature                  => RE_Set_Signature,
        Set_SSD                        => RE_Set_SSD,
-       Set_TSD                        => RE_Set_TSD,
-       Set_Tagged_Kind                => RE_Set_Tagged_Kind,
-       TSD_Entry_Size                 => RE_TSD_Entry_Size,
-       TSD_Prologue_Size              => RE_TSD_Prologue_Size);
+       Set_Tagged_Kind                => RE_Set_Tagged_Kind);
 
    Action_Is_Proc : constant array (DT_Access_Action) of Boolean :=
-      (CW_Membership                  => False,
-       IW_Membership                  => False,
-       DT_Entry_Size                  => False,
-       DT_Prologue_Size               => False,
-       Get_Access_Level               => False,
+      (IW_Membership                  => False,
        Get_Entry_Index                => False,
-       Get_External_Tag               => False,
-       Get_Predefined_Prim_Op_Address => False,
-       Get_Prim_Op_Address            => False,
        Get_Prim_Op_Kind               => False,
-       Get_RC_Offset                  => False,
-       Get_Remotely_Callable          => False,
        Get_Tagged_Kind                => False,
-       Inherit_DT                     => True,
-       Inherit_TSD                    => True,
        Register_Interface_Tag         => True,
        Register_Tag                   => True,
-       Set_Access_Level               => True,
        Set_Entry_Index                => True,
-       Set_Expanded_Name              => True,
-       Set_External_Tag               => True,
-       Set_Interface_Table            => True,
        Set_Offset_Index               => True,
        Set_OSD                        => True,
-       Set_Predefined_Prim_Op_Address => True,
-       Set_Prim_Op_Address            => True,
        Set_Prim_Op_Kind               => True,
-       Set_RC_Offset                  => True,
-       Set_Remotely_Callable          => True,
        Set_Signature                  => True,
        Set_SSD                        => True,
-       Set_TSD                        => True,
-       Set_Tagged_Kind                => True,
-       TSD_Entry_Size                 => False,
-       TSD_Prologue_Size              => False);
+       Set_Tagged_Kind                => True);
 
    Action_Nb_Arg : constant array (DT_Access_Action) of Int :=
-      (CW_Membership                  => 2,
-       IW_Membership                  => 2,
-       DT_Entry_Size                  => 0,
-       DT_Prologue_Size               => 0,
-       Get_Access_Level               => 1,
+      (IW_Membership                  => 2,
        Get_Entry_Index                => 2,
-       Get_External_Tag               => 1,
-       Get_Predefined_Prim_Op_Address => 2,
-       Get_Prim_Op_Address            => 2,
        Get_Prim_Op_Kind               => 2,
-       Get_RC_Offset                  => 1,
-       Get_Remotely_Callable          => 1,
        Get_Tagged_Kind                => 1,
-       Inherit_DT                     => 3,
-       Inherit_TSD                    => 2,
        Register_Interface_Tag         => 3,
        Register_Tag                   => 1,
-       Set_Access_Level               => 2,
        Set_Entry_Index                => 3,
-       Set_Expanded_Name              => 2,
-       Set_External_Tag               => 2,
-       Set_Interface_Table            => 2,
        Set_Offset_Index               => 3,
        Set_OSD                        => 2,
-       Set_Predefined_Prim_Op_Address => 3,
-       Set_Prim_Op_Address            => 3,
        Set_Prim_Op_Kind               => 3,
-       Set_RC_Offset                  => 2,
-       Set_Remotely_Callable          => 2,
        Set_Signature                  => 2,
        Set_SSD                        => 2,
-       Set_TSD                        => 2,
-       Set_Tagged_Kind                => 2,
-       TSD_Entry_Size                 => 0,
-       TSD_Prologue_Size              => 0);
+       Set_Tagged_Kind                => 2);
 
    function Default_Prim_Op_Position (E : Entity_Id) return Uint;
    --  Ada 2005 (AI-251): Returns the fixed position in the dispatch table
@@ -550,7 +485,18 @@ package body Exp_Disp is
    --  Start of processing for Expand_Dispatching_Call
 
    begin
-      Check_Restriction (No_Dispatching_Calls, Call_Node);
+      --  Expand_Dispatching_Call is called directly from the semantics,
+      --  so we need a check to see whether expansion is active before
+      --  proceeding. In addition, there is no need to expand the call
+      --  if we are compiling under restriction No_Dispatching_Calls;
+      --  the semantic analyzer has previously notified the violation
+      --  of this restriction.
+
+      if not Expander_Active
+        or else Restriction_Active (No_Dispatching_Calls)
+      then
+         return;
+      end if;
 
       --  Set subprogram. If this is an inherited operation that was
       --  overridden, the body that is being called is its alias.
@@ -564,14 +510,6 @@ package body Exp_Disp is
          Subp := Alias (Subp);
       end if;
 
-      --  Expand_Dispatching_Call is called directly from the semantics,
-      --  so we need a check to see whether expansion is active before
-      --  proceeding.
-
-      if not Expander_Active then
-         return;
-      end if;
-
       --  Definition of the class-wide type and the tagged type
 
       --  If the controlling argument is itself a tag rather than a tagged
@@ -606,12 +544,10 @@ package body Exp_Disp is
          Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
       end if;
 
-      --  Why do we check the Root_Type instead of Typ???
-
-      if Is_CPP_Class (Root_Type (Typ)) then
-
-         --  Create a new parameter list with the displaced 'this'
+      --  Dispatching call to C++ primitive. Create a new parameter list
+      --  with no tag checks.
 
+      if Is_CPP_Class (Typ) then
          New_Params := New_List;
          Param := First_Actual (Call_Node);
          while Present (Param) loop
@@ -619,6 +555,8 @@ package body Exp_Disp is
             Next_Actual (Param);
          end loop;
 
+      --  Dispatching call to Ada primitive
+
       elsif Present (Param_List) then
 
          --  Generate the Tag checks when appropriate
@@ -805,6 +743,22 @@ package body Exp_Disp is
       then
          Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
 
+      --  Extract the tag from an unchecked type conversion. Done to avoid
+      --  the expansion of additional code just to obtain the value of such
+      --  tag because the current management of interface type conversions
+      --  generates in some cases this unchecked type conversion with the
+      --  tag of the object (see Expand_Interface_Conversion).
+
+      elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
+        and then
+          (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
+            or else
+              (RTE_Available (RE_Interface_Tag)
+                and then
+                  Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
+      then
+         Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
+
       --  Ada 2005 (AI-251): Abstract interface class-wide type
 
       elsif Is_Interface (Etype (Ctrl_Arg))
@@ -819,42 +773,27 @@ package body Exp_Disp is
              Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
       end if;
 
-      --  Generate:
-      --   Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos));
+      --  Handle dispatching calls to predefined primitives
 
       if Is_Predefined_Dispatching_Operation (Subp)
         or else Is_Predefined_Dispatching_Alias (Subp)
       then
          New_Call_Name :=
            Unchecked_Convert_To (Subp_Ptr_Typ,
-             Make_DT_Access_Action (Typ,
-               Action => Get_Predefined_Prim_Op_Address,
-               Args => New_List (
-
-               --  Vptr
-
-                 Unchecked_Convert_To (RTE (RE_Tag),
-                   Controlling_Tag),
+             Build_Get_Predefined_Prim_Op_Address (Loc,
+               Tag_Node => Controlling_Tag,
+               Position_Node => Make_Integer_Literal (Loc,
+                                  DT_Position (Subp))));
 
-               --  Position
-
-                 Make_Integer_Literal (Loc, DT_Position (Subp)))));
+      --  Handle dispatching calls to user-defined primitives
 
       else
          New_Call_Name :=
            Unchecked_Convert_To (Subp_Ptr_Typ,
-             Make_DT_Access_Action (Typ,
-               Action => Get_Prim_Op_Address,
-               Args => New_List (
-
-               --  Vptr
-
-                 Unchecked_Convert_To (RTE (RE_Tag),
-                   Controlling_Tag),
-
-               --  Position
-
-                 Make_Integer_Literal (Loc, DT_Position (Subp)))));
+             Build_Get_Prim_Op_Address (Loc,
+               Tag_Node      => Controlling_Tag,
+               Position_Node => Make_Integer_Literal (Loc,
+                                  DT_Position (Subp))));
       end if;
 
       if Nkind (Call_Node) = N_Function_Call then
@@ -946,17 +885,14 @@ package body Exp_Disp is
       Iface_Typ   : Entity_Id           := Etype (N);
       Iface_Tag   : Entity_Id;
       New_Itype   : Entity_Id;
-      P           : Node_Id;
 
    begin
       pragma Assert (Nkind (Operand) /= N_Attribute_Reference);
 
-      --  Ada 2005 (AI-345): Handle task interfaces
+      --  Ada 2005 (AI-345): Handle synchronized interface type derivations
 
-      if Ekind (Operand_Typ) = E_Task_Type
-        or else Ekind (Operand_Typ) = E_Protected_Type
-      then
-         Operand_Typ := Corresponding_Record_Type (Operand_Typ);
+      if Is_Concurrent_Type (Operand_Typ) then
+         Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
       end if;
 
       --  Handle access types to interfaces
@@ -1145,24 +1081,10 @@ package body Exp_Disp is
                                    New_Occurrence_Of (Iface_Tag, Loc)),
                              Attribute_Name => Name_Address))))))));
 
-         --  Insert the new declaration in the nearest enclosing scope
-         --  that has declarations.
-
-         P := N;
-         while not Has_Declarations (Parent (P)) loop
-            P := Parent (P);
-         end loop;
-
-         if Is_List_Member (P) then
-            Insert_Before (P, Func);
-
-         elsif Nkind (Parent (P)) = N_Package_Specification then
-            Append_To (Visible_Declarations (Parent (P)), Func);
-
-         else
-            Append_To (Declarations (Parent (P)), Func);
-         end if;
+         --  Place function body before the expression containing
+         --  the conversion
 
+         Insert_Action (N, Func);
          Analyze (Func);
 
          if Is_Access_Type (Etype (Expression (N))) then
@@ -1282,7 +1204,7 @@ package body Exp_Disp is
             --  the interface primitives are located in the primary dispatch
             --  table.
 
-            elsif Is_Ancestor (Formal_Typ, Actual_Typ) then
+            elsif Is_Parent (Formal_Typ, Actual_Typ) then
                null;
 
             else
@@ -1334,7 +1256,7 @@ package body Exp_Disp is
             --  derivation of the interface (because in this case the interface
             --  primitives are located in the primary dispatch table)
 
-            elsif Is_Ancestor (Formal_DDT, Actual_DDT) then
+            elsif Is_Parent (Formal_DDT, Actual_DDT) then
                null;
 
             else
@@ -1646,32 +1568,23 @@ package body Exp_Disp is
         or else Is_Predefined_Dispatching_Alias (Prim)
       then
          return
-           Make_DT_Access_Action (Typ,
-             Action => Set_Predefined_Prim_Op_Address,
-             Args   => New_List (
-               Unchecked_Convert_To (RTE (RE_Tag),
-                 New_Reference_To (DT_Ptr, Loc)),                  -- DTptr
-
-               Make_Integer_Literal (Loc, Pos),                    -- Position
+           Build_Set_Predefined_Prim_Op_Address (Loc,
+             Tag_Node      => New_Reference_To (DT_Ptr, Loc),
+             Position_Node => Make_Integer_Literal (Loc, Pos),
+             Address_Node  => Make_Attribute_Reference (Loc,
+                                Prefix => New_Reference_To (Prim, Loc),
+                                Attribute_Name => Name_Address));
 
-               Make_Attribute_Reference (Loc,                      -- Value
-                 Prefix          => New_Reference_To (Prim, Loc),
-                 Attribute_Name  => Name_Address)));
       else
          pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
 
          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
-
-               Make_Integer_Literal (Loc, Pos),                    -- Position
-
-               Make_Attribute_Reference (Loc,                      -- Value
-                 Prefix          => New_Reference_To (Prim, Loc),
-                 Attribute_Name  => Name_Address)));
+           Build_Set_Prim_Op_Address (Loc,
+             Tag_Node      => New_Reference_To (DT_Ptr, Loc),
+             Position_Node => Make_Integer_Literal (Loc, Pos),
+             Address_Node  => Make_Attribute_Reference (Loc,
+                                Prefix => New_Reference_To (Prim, Loc),
+                                Attribute_Name => Name_Address));
       end if;
    end Fill_DT_Entry;
 
@@ -1685,7 +1598,6 @@ package body Exp_Disp is
       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 :=
@@ -1696,99 +1608,28 @@ package body Exp_Disp is
         or else Is_Predefined_Dispatching_Alias (Prim)
       then
          return
-           Make_DT_Access_Action (Typ,
-             Action => Set_Predefined_Prim_Op_Address,
-             Args   => New_List (
-               Unchecked_Convert_To (RTE (RE_Tag),
-                 New_Reference_To (Iface_DT_Ptr, Loc)),            -- DTptr
-
-               Make_Integer_Literal (Loc, Pos),                    -- Position
-
-               Make_Attribute_Reference (Loc,                      -- Value
+           Build_Set_Predefined_Prim_Op_Address (Loc,
+             Tag_Node =>
+               New_Reference_To (Iface_DT_Ptr, Loc),
+             Position_Node =>
+               Make_Integer_Literal (Loc, Pos),
+             Address_Node =>
+               Make_Attribute_Reference (Loc,
                  Prefix          => New_Reference_To (Thunk_Id, Loc),
-                 Attribute_Name  => Name_Address)));
+                 Attribute_Name  => Name_Address));
       else
          pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
 
          return
-           Make_DT_Access_Action (Typ,
-             Action => Set_Prim_Op_Address,
-             Args   => New_List (
-               Unchecked_Convert_To (RTE (RE_Tag),
-                 New_Reference_To (Iface_DT_Ptr, Loc)),            -- DTptr
-
-               Make_Integer_Literal (Loc, Pos),                    -- Position
-
-               Make_Attribute_Reference (Loc,                      -- Value
-                 Prefix          => New_Reference_To (Thunk_Id, Loc),
-                 Attribute_Name  => Name_Address)));
+           Build_Set_Prim_Op_Address (Loc,
+             Tag_Node      => New_Reference_To (Iface_DT_Ptr, Loc),
+             Position_Node => Make_Integer_Literal (Loc, Pos),
+             Address_Node  => Make_Attribute_Reference (Loc,
+                                Prefix => New_Reference_To (Thunk_Id, Loc),
+                                Attribute_Name => Name_Address));
       end if;
    end Fill_Secondary_DT_Entry;
 
-   ---------------------------
-   -- Get_Remotely_Callable --
-   ---------------------------
-
-   function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is
-      Loc : constant Source_Ptr := Sloc (Obj);
-   begin
-      return Make_DT_Access_Action
-        (Typ    => Etype (Obj),
-         Action => Get_Remotely_Callable,
-         Args   => New_List (
-           Make_Selected_Component (Loc,
-             Prefix        => Obj,
-             Selector_Name => Make_Identifier (Loc, Name_uTag))));
-   end Get_Remotely_Callable;
-
-   ------------------------------------------
-   -- Init_Predefined_Interface_Primitives --
-   ------------------------------------------
-
-   function Init_Predefined_Interface_Primitives
-     (Typ : Entity_Id) return List_Id
-   is
-      Loc    : constant Source_Ptr := Sloc (Typ);
-      DT_Ptr : constant Node_Id :=
-                 Node (First_Elmt (Access_Disp_Table (Typ)));
-      Result : constant List_Id := New_List;
-      AI     : Elmt_Id;
-
-   begin
-      --  No need to inherit primitives if we have an abstract interface
-      --  type or a concurrent type.
-
-      if Is_Interface (Typ)
-        or else Is_Concurrent_Record_Type (Typ)
-        or else Restriction_Active (No_Dispatching_Calls)
-      then
-         return Result;
-      end if;
-
-      AI := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
-      while Present (AI) loop
-
-         --  All the secondary tables inherit the dispatch table entries
-         --  associated with predefined primitives.
-
-         --  Generate:
-         --    Inherit_DT (T'Tag, Iface'Tag, 0);
-
-         Append_To (Result,
-           Make_DT_Access_Action (Typ,
-             Action => Inherit_DT,
-             Args   => New_List (
-               Node1 => New_Reference_To (DT_Ptr, Loc),
-               Node2 => Unchecked_Convert_To (RTE (RE_Tag),
-                          New_Reference_To (Node (AI), Loc)),
-               Node3 => Make_Integer_Literal (Loc, Uint_0))));
-
-         Next_Elmt (AI);
-      end loop;
-
-      return Result;
-   end Init_Predefined_Interface_Primitives;
-
    -------------------------------------
    -- Is_Predefined_Dispatching_Alias --
    -------------------------------------
@@ -2651,6 +2492,8 @@ package body Exp_Disp is
       Name_TSD    : constant Name_Id := New_External_Name (Tname, 'B');
       Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
       Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F');
+
+      --  The following external name is only generated if Typ has interfaces
       Name_ITable : Name_Id;
 
       DT     : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
@@ -2659,23 +2502,26 @@ package body Exp_Disp is
       TSD    : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD);
       Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname);
       No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg);
-      ITable : Node_Id;
-
-      Generalized_Tag   : constant Entity_Id := RTE (RE_Tag);
-      AI                : Elmt_Id;
-      I_Depth           : Int;
-      Nb_Prim           : Int;
-      Num_Ifaces        : Int;
-      Old_Tag1          : Node_Id;
-      Old_Tag2          : Node_Id;
-      Parent_Num_Ifaces : Int;
-      Size_Expr_Node    : Node_Id;
-      TSD_Num_Entries   : Int;
 
-      Empty_DT          : Boolean := False;
-
-      Ancestor_Ifaces   : Elist_Id;
-      Typ_Ifaces        : Elist_Id;
+      Generalized_Tag    : constant Entity_Id := RTE (RE_Tag);
+      Ancestor_Ifaces    : Elist_Id;
+      AI                 : Elmt_Id;
+      Has_Dispatch_Table : Boolean := True;
+      I_Depth            : Nat := 0;
+      ITable             : Node_Id;
+      Iface_Table_Node   : Node_Id;
+      Nb_Prim            : Nat := 0;
+      Null_Parent_Tag    : Boolean := False;
+      Num_Ifaces         : Nat := 0;
+      Old_Tag1           : Node_Id;
+      Old_Tag2           : Node_Id;
+      Parent             : Entity_Id;
+      Parent_Num_Ifaces  : Nat := 0;
+      Remotely_Callable  : Entity_Id;
+      RC_Offset_Node     : Node_Id;
+      Size_Expr_Node     : Node_Id;
+      Typ_Ifaces         : Elist_Id;
+      TSD_Aggr_List      : List_Id;
 
    begin
       if not RTE_Available (RE_Tag) then
@@ -2683,34 +2529,49 @@ package body Exp_Disp is
          return New_List;
       end if;
 
-      --  Calculate the size of the DT and the TSD. First we count the number
-      --  of interfaces implemented by the ancestors
+      --  Ensure that the unit System_Storage_Elements is loaded. This is
+      --  required to properly expand the routines of Ada.Tags
+
+      if not RTU_Loaded (System_Storage_Elements)
+        and then not Present (RTE (RE_Storage_Offset))
+      then
+         raise Program_Error;
+      end if;
+
+      if Ada_Version >= Ada_05 then
+
+         --  Count the interface types of the parents
+
+         Parent := Empty;
+
+         if Typ /= Etype (Typ) then
+            Parent := Etype (Typ);
+
+         elsif Is_Concurrent_Record_Type (Typ) then
+            Parent := Etype (First (Abstract_Interface_List (Typ)));
+         end if;
+
+         if Present (Parent) then
+            Collect_Abstract_Interfaces (Parent, Ancestor_Ifaces);
 
-      Parent_Num_Ifaces := 0;
-      Num_Ifaces        := 0;
+            AI := First_Elmt (Ancestor_Ifaces);
+            while Present (AI) loop
+               Parent_Num_Ifaces := Parent_Num_Ifaces + 1;
+               Next_Elmt (AI);
+            end loop;
+         end if;
 
-      --  Count the abstract interfaces of the ancestors
+         --  Count the additional interfaces implemented by Typ
 
-      if Typ /= Etype (Typ) then
-         Collect_Abstract_Interfaces (Etype (Typ), Ancestor_Ifaces);
+         Collect_Abstract_Interfaces (Typ, Typ_Ifaces);
 
-         AI := First_Elmt (Ancestor_Ifaces);
+         AI := First_Elmt (Typ_Ifaces);
          while Present (AI) loop
-            Parent_Num_Ifaces := Parent_Num_Ifaces + 1;
+            Num_Ifaces := Num_Ifaces + 1;
             Next_Elmt (AI);
          end loop;
       end if;
 
-      --  Count the number of additional interfaces implemented by Typ
-
-      Collect_Abstract_Interfaces (Typ, Typ_Ifaces);
-
-      AI := First_Elmt (Typ_Ifaces);
-      while Present (AI) loop
-         Num_Ifaces := Num_Ifaces + 1;
-         Next_Elmt (AI);
-      end loop;
-
       --  Count ancestors to compute the inheritance depth. For private
       --  extensions, always go to the full view in order to compute the
       --  real inheritance depth.
@@ -2735,31 +2596,19 @@ package body Exp_Disp is
          end loop;
       end;
 
-      --  Abstract interfaces don't need the DT. We reserve a single entry
-      --  for its DT because at run-time the pointer to this dummy DT will
-      --  be used as the tag of this abstract interface type. The table of
-      --  interfaces is required to give support to AI-405
-
-      if Is_Interface (Typ) then
-         Empty_DT := True;
-         Nb_Prim  := 1;
-         TSD_Num_Entries := 0;
+      --  Calculate the number of primitives of the dispatch table and the
+      --  size of the Type_Specific_Data record.
 
-      else
-         TSD_Num_Entries := I_Depth + 1;
-         Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
+      --  Abstract interfaces don't need the dispatch table. In addition,
+      --  compiling with restriction No_Dispatching_Calls we do not generate
+      --  the dispatch table.
 
-         --  If the number of primitives of Typ is 0 (or we are compiling
-         --  with the No_Dispatching_Calls restriction) we reserve a dummy
-         --  single entry for its DT because at run-time the pointer to this
-         --  dummy DT will be used as the tag of this tagged type.
+      Has_Dispatch_Table :=
+        not Is_Interface (Typ)
+          and then not Restriction_Active (No_Dispatching_Calls);
 
-         if Nb_Prim = 0
-           or else Restriction_Active (No_Dispatching_Calls)
-         then
-            Empty_DT := True;
-            Nb_Prim  := 1;
-         end if;
+      if Has_Dispatch_Table then
+         Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
       end if;
 
       --  Dispatch table and related entities are allocated statically
@@ -2792,18 +2641,49 @@ package body Exp_Disp is
 
       --  Generate code to create the storage for the Dispatch_Table object:
 
-      --   DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
+      --   DT : Storage_Array (1 .. Size_Expr);
       --   for DT'Alignment use Address'Alignment
 
-      Size_Expr_Node :=
-        Make_Op_Add (Loc,
-          Left_Opnd  => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List),
-          Right_Opnd =>
-            Make_Op_Multiply (Loc,
-              Left_Opnd  =>
-                Make_DT_Access_Action (Typ, DT_Entry_Size, No_List),
-              Right_Opnd =>
-                Make_Integer_Literal (Loc, Nb_Prim)));
+      --  Under No_Dispatching_Calls the size of the table is small just
+      --  containing:
+      --   1) the pointer to the TSD
+      --   2) a dummy entry used as the Tag of the type (see a-tags.ads).
+
+      if not Has_Dispatch_Table then
+         Size_Expr_Node :=
+           New_Reference_To (RTE (RE_DT_Min_Prologue_Size), Loc);
+
+      --  If the object has no primitives we ensure that the table will
+      --  have at least a dummy entry which will be used as the Tag.
+
+      --   Size_Expr := DT_Prologue_Size + DT_Entry_Size
+
+      elsif Nb_Prim = 0 then
+         Size_Expr_Node :=
+           Make_Op_Add (Loc,
+             Left_Opnd  =>
+               New_Reference_To (RTE (RE_DT_Prologue_Size), Loc),
+             Right_Opnd =>
+               New_Reference_To (RTE (RE_DT_Entry_Size), Loc));
+
+      --  Common case. The dispatch table has space to save the pointers to
+      --  all the predefined primitives, the C++ ABI header of the DT, and
+      --  the pointers to the primitives of Typ. That is,
+
+      --   Size_Expr := DT_Prologue_Size + nb_prim * DT_Entry_Size
+
+      else
+         Size_Expr_Node :=
+           Make_Op_Add (Loc,
+             Left_Opnd  =>
+               New_Reference_To (RTE (RE_DT_Prologue_Size), Loc),
+             Right_Opnd =>
+               Make_Op_Multiply (Loc,
+                 Left_Opnd  =>
+                   New_Reference_To (RTE (RE_DT_Entry_Size), Loc),
+                 Right_Opnd =>
+                   Make_Integer_Literal (Loc, Nb_Prim)));
+      end if;
 
       Append_To (Result,
         Make_Object_Declaration (Loc,
@@ -2836,34 +2716,42 @@ package body Exp_Disp is
       --  prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move
       --  down the pointer to the real base of the vtable
 
-      Append_To (Result,
-        Make_Object_Declaration (Loc,
-          Defining_Identifier => DT_Ptr,
-          Constant_Present    => True,
-          Object_Definition   => New_Reference_To (Generalized_Tag, Loc),
-          Expression          =>
-            Unchecked_Convert_To (Generalized_Tag,
-              Make_Op_Add (Loc,
-                Left_Opnd =>
-                  Unchecked_Convert_To (RTE (RE_Storage_Offset),
-                    Make_Attribute_Reference (Loc,
-                      Prefix         => New_Reference_To (DT, Loc),
-                      Attribute_Name => Name_Address)),
-                Right_Opnd =>
-                  Make_DT_Access_Action (Typ,
-                    DT_Prologue_Size, No_List)))));
-
-      --  Generate code to define the boolean that controls registration, in
-      --  order to avoid multiple registrations for tagged types defined in
-      --  multiple-called scopes.
+      if not Has_Dispatch_Table then
+         Append_To (Result,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => DT_Ptr,
+             Constant_Present    => True,
+             Object_Definition   => New_Reference_To (Generalized_Tag, Loc),
+             Expression          =>
+               Unchecked_Convert_To (Generalized_Tag,
+                 Make_Op_Add (Loc,
+                   Left_Opnd =>
+                     Unchecked_Convert_To (RTE (RE_Storage_Offset),
+                       Make_Attribute_Reference (Loc,
+                         Prefix         => New_Reference_To (DT, Loc),
+                         Attribute_Name => Name_Address)),
+                   Right_Opnd =>
+                     New_Reference_To (RTE (RE_DT_Typeinfo_Ptr_Size), Loc)))));
 
-      Append_To (Result,
-        Make_Object_Declaration (Loc,
-          Defining_Identifier => No_Reg,
-          Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
-          Expression          => New_Reference_To (Standard_True, Loc)));
+      else
+         Append_To (Result,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => DT_Ptr,
+             Constant_Present    => True,
+             Object_Definition   => New_Reference_To (Generalized_Tag, Loc),
+             Expression          =>
+               Unchecked_Convert_To (Generalized_Tag,
+                 Make_Op_Add (Loc,
+                   Left_Opnd =>
+                     Unchecked_Convert_To (RTE (RE_Storage_Offset),
+                       Make_Attribute_Reference (Loc,
+                         Prefix         => New_Reference_To (DT, Loc),
+                         Attribute_Name => Name_Address)),
+                   Right_Opnd =>
+                     New_Reference_To (RTE (RE_DT_Prologue_Size), Loc)))));
+      end if;
 
-      --  Set Access_Disp_Table field to be the dispatch table pointer
+      --  Save the tag in the Access_Disp_Table attribute
 
       if No (Access_Disp_Table (Typ)) then
          Set_Access_Disp_Table (Typ, New_Elmt_List);
@@ -2871,57 +2759,28 @@ package body Exp_Disp is
 
       Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ));
 
-      --  Generate code to create the storage for the type specific data object
-      --  with enough space to store the tags of the ancestors plus the tags
-      --  of all the implemented interfaces (as described in a-tags.adb).
-
-      --   TSD: Storage_Array
-      --     (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size);
-      --   for TSD'Alignment use Address'Alignment
-
-      Size_Expr_Node :=
-        Make_Op_Add (Loc,
-          Left_Opnd  =>
-            Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List),
-          Right_Opnd =>
-            Make_Op_Multiply (Loc,
-              Left_Opnd  =>
-                Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List),
-              Right_Opnd =>
-                Make_Integer_Literal (Loc, TSD_Num_Entries)));
+      --  Generate code to define the boolean that controls registration, in
+      --  order to avoid multiple registrations for tagged types defined in
+      --  multiple-called scopes.
 
       Append_To (Result,
         Make_Object_Declaration (Loc,
-          Defining_Identifier => TSD,
-          Aliased_Present     => True,
-          Object_Definition   =>
-            Make_Subtype_Indication (Loc,
-              Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
-              Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
-                Constraints => New_List (
-                  Make_Range (Loc,
-                    Low_Bound  => Make_Integer_Literal (Loc, 1),
-                    High_Bound => Size_Expr_Node))))));
-
-      Append_To (Result,
-        Make_Attribute_Definition_Clause (Loc,
-          Name       => New_Reference_To (TSD, Loc),
-          Chars      => Name_Alignment,
-          Expression =>
-            Make_Attribute_Reference (Loc,
-              Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
-              Attribute_Name => Name_Alignment)));
+          Defining_Identifier => No_Reg,
+          Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
+          Expression          => New_Reference_To (Standard_True, Loc)));
 
       --  Generate:
       --    Set_Signature (DT_Ptr, Value);
 
-      if RTE_Available (RE_Set_Signature) then
+      if Has_Dispatch_Table
+        and then RTE_Available (RE_Set_Signature)
+      then
          if Is_Interface (Typ) then
             Append_To (Elab_Code,
               Make_DT_Access_Action (Typ,
                 Action => Set_Signature,
                 Args   => New_List (
-                  New_Reference_To (DT_Ptr, Loc),                  -- DTptr
+                  New_Reference_To (DT_Ptr, Loc),
                   New_Reference_To (RTE (RE_Abstract_Interface), Loc))));
 
          else
@@ -2929,88 +2788,240 @@ package body Exp_Disp is
               Make_DT_Access_Action (Typ,
                 Action => Set_Signature,
                 Args   => New_List (
-                  New_Reference_To (DT_Ptr, Loc),                  -- DTptr
+                  New_Reference_To (DT_Ptr, Loc),
                   New_Reference_To (RTE (RE_Primary_DT), Loc))));
          end if;
       end if;
 
-      --  Generate code to put the Address of the TSD in the dispatch table
-      --    Set_TSD (DT_Ptr, TSD);
+      --  Generate: Exname : constant String := full_qualified_name (typ);
+      --  The type itself may be an anonymous parent type, so use the first
+      --  subtype to have a user-recognizable name.
 
-      Append_To (Elab_Code,
-        Make_DT_Access_Action (Typ,
-          Action => Set_TSD,
-          Args   => New_List (
-            New_Reference_To (DT_Ptr, Loc),                  -- DTptr
-              Make_Attribute_Reference (Loc,                 -- Value
-                Prefix          => New_Reference_To (TSD, Loc),
-                Attribute_Name  => Name_Address))));
+      Append_To (Result,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => Exname,
+          Constant_Present    => True,
+          Object_Definition   => New_Reference_To (Standard_String, Loc),
+          Expression =>
+            Make_String_Literal (Loc,
+              Full_Qualified_Name (First_Subtype (Typ)))));
 
-      --  Set the pointer to the Interfaces_Table (if any). Otherwise the
-      --  corresponding access component is set to null.
+      --  Calculate the value of the RC_Offset component. These are the
+      --  valid valiues and their meaning:
+      --   >0: For simple types with controlled components is
+      --         type._record_controller'position
+      --    0: For types with no controlled components
+      --   -1: For complex types with controlled components where the position
+      --       of the record controller is not statically computable but there
+      --       are controlled components at this level. The _Controller field
+      --       is available right after the _parent.
+      --   -2: There are no controlled components at this level. We need to
+      --       get the position from the parent.
 
-      if Num_Ifaces = 0 then
-         if RTE_Available (RE_Set_Interface_Table) then
-            Append_To (Elab_Code,
-              Make_DT_Access_Action (Typ,
-                Action => Set_Interface_Table,
-                Args   => New_List (
-                  New_Reference_To (DT_Ptr, Loc),                    -- DTptr
-                  New_Reference_To (RTE (RE_Null_Address), Loc))));  -- null
+      if Is_Interface (Typ)
+        or else not Has_Controlled_Component (Typ)
+      then
+         RC_Offset_Node := Make_Integer_Literal (Loc, 0);
+
+      elsif Etype (Typ) /= Typ
+        and then Has_Discriminants (Etype (Typ))
+      then
+         if Has_New_Controlled_Component (Typ) then
+            RC_Offset_Node := Make_Integer_Literal (Loc, -1);
+         else
+            RC_Offset_Node := Make_Integer_Literal (Loc, -2);
          end if;
+      else
+         RC_Offset_Node :=
+           Make_Attribute_Reference (Loc,
+             Prefix =>
+               Make_Selected_Component (Loc,
+                 Prefix => New_Reference_To (Typ, Loc),
+                 Selector_Name =>
+                   New_Reference_To (Controller_Component (Typ), Loc)),
+             Attribute_Name => Name_Position);
+
+         --  This is not proper Ada code to use the attribute 'Position
+         --  on something else than an object but this is supported by
+         --  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 (RC_Offset_Node);
+         Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller));
+         Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ);
+         Set_Etype (Selector_Name (Prefix (RC_Offset_Node)),
+           RTE (RE_Record_Controller));
+         Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset));
+      end if;
 
-      --  Generate the Interface_Table object and set the access
-      --  component if the TSD to it.
+      --  Set the pointer to the Interfaces_Table (if any). Otherwise the
+      --  corresponding access component is set to null. The table of
+      --  interfaces is required for AI-405
 
-      elsif RTE_Available (RE_Set_Interface_Table) then
-         Append_To (Result,
-           Make_Object_Declaration (Loc,
-             Defining_Identifier => ITable,
-             Aliased_Present     => True,
-             Object_Definition   =>
-               Make_Subtype_Indication (Loc,
-                 Subtype_Mark => New_Reference_To
-                   (RTE (RE_Interface_Data), Loc),
-                 Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
-                   Constraints => New_List (
-                     Make_Integer_Literal (Loc,
-                       Num_Ifaces))))));
+      if RTE_Record_Component_Available (RE_Ifaces_Table_Ptr) then
+         if Num_Ifaces = 0 then
+            Iface_Table_Node :=
+              New_Reference_To (RTE (RE_Null_Address), Loc);
 
-         Append_To (Elab_Code,
-           Make_DT_Access_Action (Typ,
-             Action => Set_Interface_Table,
-             Args   => New_List (
-               New_Reference_To (DT_Ptr, Loc),               -- DTptr
-               Make_Attribute_Reference (Loc,                -- Value
-                 Prefix         => New_Reference_To (ITable, Loc),
-                 Attribute_Name => Name_Address))));
+         --  Generate the Interface_Table object.
+
+         else
+            Append_To (Result,
+              Make_Object_Declaration (Loc,
+                Defining_Identifier => ITable,
+                Aliased_Present     => True,
+                Object_Definition   =>
+                  Make_Subtype_Indication (Loc,
+                    Subtype_Mark => New_Reference_To
+                      (RTE (RE_Interface_Data), Loc),
+                    Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
+                      Constraints => New_List (
+                        Make_Integer_Literal (Loc,
+                          Num_Ifaces))))));
+
+            Iface_Table_Node :=
+              Make_Attribute_Reference (Loc,
+                Prefix         => New_Reference_To (ITable, Loc),
+                Attribute_Name => Name_Address);
+         end if;
       end if;
 
-      --  Generate:
-      --    Set_Num_Prim_Ops (T'Tag, Nb_Prim)
+      --  Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is
+      --  described in E.4 (18)
 
-      if RTE_Available (RE_Set_Num_Prim_Ops) then
-         if not Is_Interface (Typ) then
-            if Empty_DT then
-               Append_To (Elab_Code,
-                 Make_Procedure_Call_Statement (Loc,
-                   Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
-                   Parameter_Associations => New_List (
-                     New_Reference_To (DT_Ptr, Loc),
-                     Make_Integer_Literal (Loc, Uint_0))));
-            else
-               Append_To (Elab_Code,
-                 Make_Procedure_Call_Statement (Loc,
-                   Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
-                   Parameter_Associations => New_List (
-                     New_Reference_To (DT_Ptr, Loc),
-                     Make_Integer_Literal (Loc, Nb_Prim))));
-            end if;
-         end if;
+      Remotely_Callable :=
+        Boolean_Literals
+          (Is_Pure (Typ)
+             or else Is_Shared_Passive (Typ)
+             or else
+               ((Is_Remote_Types (Typ)
+                   or else Is_Remote_Call_Interface (Typ))
+                and then Original_View_In_Visible_Part (Typ))
+             or else not Comes_From_Source (Typ));
 
+      --  Generate code to create the storage for the type specific data object
+      --  with enough space to store the tags of the ancestors plus the tags
+      --  of all the implemented interfaces (as described in a-tags.adb).
+
+      --   TSD : Type_Specific_Data (I_Depth) :=
+      --           (Idepth        => I_Depth,
+      --            Access_Level  => Type_Access_Level (Typ),
+      --            Expanded_Name => Cstring_Ptr!(Exname'Address))
+      --            [ External_Tag  => Cstring_Ptr!(Exname'Address)) ]
+      --            RC_Offset     => <<integer-value>>,
+      --            Remotely_Callable => <<boolean-value>>
+      --            [ Ifaces_Table_Ptr => <<access-value>> ]
+      --            others => <>);
+      --   for TSD'Alignment use Address'Alignment
+
+      TSD_Aggr_List := New_List (
+        Make_Component_Association (Loc,
+          Choices => New_List (
+            New_Occurrence_Of (RTE_Record_Component (RE_Idepth), Loc)),
+          Expression => Make_Integer_Literal (Loc, I_Depth)),
+
+        Make_Component_Association (Loc,
+          Choices => New_List (
+            New_Occurrence_Of (RTE_Record_Component (RE_Access_Level), Loc)),
+          Expression => Make_Integer_Literal (Loc, Type_Access_Level (Typ))),
+
+        Make_Component_Association (Loc,
+          Choices => New_List (
+            New_Occurrence_Of
+              (RTE_Record_Component (RE_Expanded_Name), Loc)),
+          Expression =>
+            Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
+              Make_Attribute_Reference (Loc,
+                Prefix => New_Reference_To (Exname, Loc),
+                Attribute_Name => Name_Address))));
+
+      if not Has_External_Tag_Rep_Clause (Typ) then
+
+         --  Should be the external name not the qualified name???
+
+         Append_To (TSD_Aggr_List,
+           Make_Component_Association (Loc,
+             Choices => New_List (
+               New_Occurrence_Of
+                 (RTE_Record_Component (RE_External_Tag), Loc)),
+             Expression =>
+               Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
+                 Make_Attribute_Reference (Loc,
+                   Prefix => New_Reference_To (Exname, Loc),
+                   Attribute_Name => Name_Address))));
+      end if;
+
+      Append_List_To (TSD_Aggr_List, New_List (
+        Make_Component_Association (Loc,
+          Choices => New_List (
+            New_Occurrence_Of (RTE_Record_Component (RE_RC_Offset), Loc)),
+          Expression => RC_Offset_Node),
+
+        Make_Component_Association (Loc,
+          Choices => New_List (
+            New_Occurrence_Of
+             (RTE_Record_Component (RE_Remotely_Callable), Loc)),
+          Expression => New_Occurrence_Of (Remotely_Callable, Loc))));
+
+      if RTE_Record_Component_Available (RE_Ifaces_Table_Ptr) then
+         Append_To (TSD_Aggr_List,
+           Make_Component_Association (Loc,
+             Choices => New_List (
+               New_Occurrence_Of
+                (RTE_Record_Component (RE_Ifaces_Table_Ptr), Loc)),
+             Expression => Iface_Table_Node));
+      end if;
+
+      Append_To (TSD_Aggr_List,
+        Make_Component_Association (Loc,
+          Choices     => New_List (Make_Others_Choice (Loc)),
+          Expression  => Empty,
+          Box_Present => True));
+
+      --  Save the expanded name in the dispatch table
+
+      Append_To (Result,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => TSD,
+          Aliased_Present     => True,
+          Object_Definition   =>
+            Make_Subtype_Indication (Loc,
+              Subtype_Mark => New_Reference_To (
+                RTE (RE_Type_Specific_Data), Loc),
+              Constraint =>
+                Make_Index_Or_Discriminant_Constraint (Loc,
+                  Constraints => New_List (
+                    Make_Integer_Literal (Loc, I_Depth)))),
+          Expression => Make_Aggregate (Loc,
+            Component_Associations => TSD_Aggr_List)));
+
+      Append_To (Result,
+        Make_Attribute_Definition_Clause (Loc,
+          Name       => New_Reference_To (TSD, Loc),
+          Chars      => Name_Alignment,
+          Expression =>
+            Make_Attribute_Reference (Loc,
+              Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
+              Attribute_Name => Name_Alignment)));
+
+      --  Generate code to put the Address of the TSD in the dispatch table
+
+      Append_To (Elab_Code,
+        Build_Set_TSD (Loc,
+          Tag_Node => New_Reference_To (DT_Ptr, Loc),
+          Value_Node =>
+            Make_Attribute_Reference (Loc,
+              Prefix          => New_Reference_To (TSD, Loc),
+              Attribute_Name  => Name_Address)));
+
+      --  Generate extra code required for synchronized interfaces
+
+      if RTE_Available (RE_Set_Tagged_Kind) then
          if Ada_Version >= Ada_05
            and then not Is_Interface  (Typ)
-           and then not Is_Abstract   (Typ)
+           and then not Is_Abstract_Type   (Typ)
            and then not Is_Controlled (Typ)
            and then not Restriction_Active (No_Dispatching_Calls)
          then
@@ -3029,13 +3040,12 @@ package body Exp_Disp is
             --  of the table is constrained by the number of non-predefined
             --  primitive operations.
 
-            if not Empty_DT
+            if Has_Dispatch_Table
               and then Is_Concurrent_Record_Type (Typ)
-              and then Implements_Interface (
-                         Typ          => Typ,
-                         Kind         => Any_Limited_Interface,
-                         Check_Parent => True)
+              and then Has_Abstract_Interfaces (Typ)
             then
+               --  No need to generate this code if Nb_Prim = 0 ???
+
                Append_To (Result,
                  Make_Object_Declaration (Loc,
                    Defining_Identifier => SSD,
@@ -3063,46 +3073,10 @@ package body Exp_Disp is
          end if;
       end if;
 
-      --  Generate: Exname : constant String := full_qualified_name (typ);
-      --  The type itself may be an anonymous parent type, so use the first
-      --  subtype to have a user-recognizable name.
-
-      Append_To (Result,
-        Make_Object_Declaration (Loc,
-          Defining_Identifier => Exname,
-          Constant_Present    => True,
-          Object_Definition   => New_Reference_To (Standard_String, Loc),
-          Expression =>
-            Make_String_Literal (Loc,
-              Full_Qualified_Name (First_Subtype (Typ)))));
-
-      --  Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
-
-      Append_To (Elab_Code,
-        Make_DT_Access_Action (Typ,
-          Action => Set_Expanded_Name,
-          Args   => New_List (
-            Node1 => New_Reference_To (DT_Ptr, Loc),
-            Node2 =>
-              Make_Attribute_Reference (Loc,
-                Prefix => New_Reference_To (Exname, Loc),
-                Attribute_Name => Name_Address))));
-
-      if not Is_Interface (Typ) then
-         --  Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>);
-
-         Append_To (Elab_Code,
-           Make_DT_Access_Action (Typ,
-             Action => Set_Access_Level,
-             Args   => New_List (
-               Node1 => New_Reference_To (DT_Ptr, Loc),
-               Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ)))));
-      end if;
-
       --  If the ancestor is a CPP_Class type we inherit the dispatch tables
       --  in the init proc, and we don't need to fill them in here.
 
-      if Is_CPP_Class (Etype (Typ)) and then not Debug_Flag_QQ then
+      if Is_CPP_Class (Etype (Typ)) then
          null;
 
          --  Otherwise we fill in the dispatch tables here
@@ -3112,6 +3086,8 @@ package body Exp_Disp is
            or else Is_CPP_Class (Etype (Typ))
            or else Is_Interface (Typ)
          then
+            Null_Parent_Tag := True;
+
             Old_Tag1 :=
               Unchecked_Convert_To (Generalized_Tag,
                 Make_Integer_Literal (Loc, 0));
@@ -3132,27 +3108,34 @@ package body Exp_Disp is
            and then not Is_Interface (Typ)
            and then not Restriction_Active (No_Dispatching_Calls)
          then
-            --  Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
+            --  Inherit the dispatch table
 
             if not Is_Interface (Etype (Typ)) then
                if Restriction_Active (No_Dispatching_Calls) then
-                  Append_To (Elab_Code,
-                    Make_DT_Access_Action (Typ,
-                      Action => Inherit_DT,
-                      Args   => New_List (
-                        Node1 => Old_Tag1,
-                        Node2 => New_Reference_To (DT_Ptr, Loc),
-                        Node3 => Make_Integer_Literal (Loc, Uint_0))));
+                  null;
+
                else
-                  Append_To (Elab_Code,
-                    Make_DT_Access_Action (Typ,
-                      Action => Inherit_DT,
-                      Args   => New_List (
-                        Node1 => Old_Tag1,
-                        Node2 => New_Reference_To (DT_Ptr, Loc),
-                        Node3 => Make_Integer_Literal (Loc,
-                                   DT_Entry_Count
-                                     (First_Tag_Component (Etype (Typ)))))));
+                  if not Null_Parent_Tag then
+                     declare
+                        Nb_Prims : constant Int :=
+                                     UI_To_Int (DT_Entry_Count
+                                       (First_Tag_Component (Etype (Typ))));
+                     begin
+                        Append_To (Elab_Code,
+                          Build_Inherit_Predefined_Prims (Loc,
+                            Old_Tag_Node => Old_Tag1,
+                            New_Tag_Node =>
+                              New_Reference_To (DT_Ptr, Loc)));
+
+                        if Nb_Prims /= 0 then
+                           Append_To (Elab_Code,
+                             Build_Inherit_Prims (Loc,
+                               Old_Tag_Node => Old_Tag2,
+                               New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
+                               Num_Prims    => Nb_Prims));
+                        end if;
+                     end;
+                  end if;
                end if;
             end if;
 
@@ -3207,21 +3190,41 @@ package body Exp_Disp is
                         loop
                            if Is_Tag (E) and then Chars (E) /= Name_uTag then
                               if not Is_Interface (Etype (Typ)) 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)))));
+
+                                 --  Inherit the dispatch table
+
+                                 declare
+                                    Num_Prims : constant Int :=
+                                                UI_To_Int (DT_Entry_Count (E));
+                                 begin
+                                    Append_To (Elab_Code,
+                                      Build_Inherit_Predefined_Prims (Loc,
+                                        Old_Tag_Node =>
+                                          Unchecked_Convert_To (RTE (RE_Tag),
+                                             New_Reference_To
+                                               (Node (Sec_DT_Ancestor), Loc)),
+                                        New_Tag_Node =>
+                                          Unchecked_Convert_To (RTE (RE_Tag),
+                                            New_Reference_To
+                                              (Node (Sec_DT_Typ), Loc))));
+
+                                    if Num_Prims /= 0 then
+                                       Append_To (Elab_Code,
+                                         Build_Inherit_Prims (Loc,
+                                           Old_Tag_Node =>
+                                             Unchecked_Convert_To
+                                               (RTE (RE_Tag),
+                                                New_Reference_To
+                                                  (Node (Sec_DT_Ancestor),
+                                                   Loc)),
+                                           New_Tag_Node =>
+                                             Unchecked_Convert_To
+                                              (RTE (RE_Tag),
+                                               New_Reference_To
+                                                 (Node (Sec_DT_Typ), Loc)),
+                                           Num_Prims => Num_Prims));
+                                    end if;
+                                 end;
                               end if;
 
                               Next_Elmt (Sec_DT_Ancestor);
@@ -3253,157 +3256,68 @@ package body Exp_Disp is
          --    Inherit_TSD (parent'tag, DT_Ptr);
 
          if not Is_Interface (Typ) then
-            Append_To (Elab_Code,
-              Make_DT_Access_Action (Typ,
-                Action => Inherit_TSD,
-                Args   => New_List (
-                  Node1 => Old_Tag2,
-                  Node2 => New_Reference_To (DT_Ptr, Loc))));
-         end if;
-      end if;
-
-      if not Is_Interface (Typ) then
-
-         --  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);
-         --  to indicate that we need to get the position from the parent.
-
-         declare
-            Position : Node_Id;
-
-         begin
-            if not Has_Controlled_Component (Typ) then
-               Position := Make_Integer_Literal (Loc, 0);
-
-            elsif Etype (Typ) /= Typ
-              and then Has_Discriminants (Etype (Typ))
+            if Typ = Etype (Typ)
+              or else Is_CPP_Class (Etype (Typ))
             then
-               if Has_New_Controlled_Component (Typ) then
-                  Position := Make_Integer_Literal (Loc, -1);
-               else
-                  Position := Make_Integer_Literal (Loc, -2);
-               end if;
-            else
-               Position :=
-                 Make_Attribute_Reference (Loc,
-                   Prefix =>
-                     Make_Selected_Component (Loc,
-                       Prefix => New_Reference_To (Typ, Loc),
-                       Selector_Name =>
-                         New_Reference_To (Controller_Component (Typ), Loc)),
-                   Attribute_Name => Name_Position);
-
-               --  This is not proper Ada code to use the attribute 'Position
-               --  on something else than an object but this is supported by
-               --  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);
-               Set_Etype (Selector_Name (Prefix (Position)),
-                 RTE (RE_Record_Controller));
-               Set_Etype (Position, RTE (RE_Storage_Offset));
-            end if;
+               --  New_TSD (DT_Ptr);
 
-            Append_To (Elab_Code,
-              Make_DT_Access_Action (Typ,
-                Action => Set_RC_Offset,
-                Args   => New_List (
-                  Node1 => New_Reference_To (DT_Ptr, Loc),
-                  Node2 => Position)));
-         end;
-
-         --  Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is
-         --  described in E.4 (18)
-
-         declare
-            Status : Entity_Id;
-
-         begin
-            Status :=
-              Boolean_Literals
-                (Is_Pure (Typ)
-                   or else Is_Shared_Passive (Typ)
-                   or else
-                     ((Is_Remote_Types (Typ)
-                         or else Is_Remote_Call_Interface (Typ))
-                      and then Original_View_In_Visible_Part (Typ))
-                   or else not Comes_From_Source (Typ));
-
-            Append_To (Elab_Code,
-              Make_DT_Access_Action (Typ,
-                Action => Set_Remotely_Callable,
-                Args   => New_List (
-                  New_Occurrence_Of (DT_Ptr, Loc),
-                  New_Occurrence_Of (Status, Loc))));
-         end;
-
-         if RTE_Available (RE_Set_Offset_To_Top) then
-            --  Generate:
-            --    Set_Offset_To_Top (0, DT_Ptr, True, 0, null);
+               Append_List_To (Elab_Code,
+                 Build_New_TSD (Loc,
+                   New_Tag_Node => New_Reference_To (DT_Ptr, Loc)));
+            else
+               --  Inherit_TSD (parent'tag, DT_Ptr);
 
-            Append_To (Elab_Code,
-              Make_Procedure_Call_Statement (Loc,
-                Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
-                Parameter_Associations => New_List (
-                  New_Reference_To (RTE (RE_Null_Address), Loc),
-                  New_Reference_To (DT_Ptr, Loc),
-                  New_Occurrence_Of (Standard_True, Loc),
-                  Make_Integer_Literal (Loc, Uint_0),
-                  New_Reference_To (RTE (RE_Null_Address), Loc))));
+               Append_To (Elab_Code,
+                 Build_Inherit_TSD (Loc,
+                   Old_Tag_Node =>
+                     New_Reference_To
+                       (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))),
+                        Loc),
+                   New_Tag_Node      => New_Reference_To (DT_Ptr, Loc),
+                   I_Depth           => I_Depth,
+                   Parent_Num_Ifaces => Parent_Num_Ifaces));
+            end if;
          end if;
       end if;
 
-      --  Generate: Set_External_Tag (DT_Ptr, exname'Address);
-      --  Should be the external name not the qualified name???
+      if not Is_Interface (Typ)
+        and then RTE_Available (RE_Set_Offset_To_Top)
+      then
+         --  Generate:
+         --    Set_Offset_To_Top (0, DT_Ptr, True, 0, null);
 
-      if not Has_External_Tag_Rep_Clause (Typ) then
          Append_To (Elab_Code,
-           Make_DT_Access_Action (Typ,
-             Action => Set_External_Tag,
-             Args   => New_List (
-               Node1 => New_Reference_To (DT_Ptr, Loc),
-               Node2 =>
-                 Make_Attribute_Reference (Loc,
-                   Prefix => New_Reference_To (Exname, Loc),
-                   Attribute_Name => Name_Address))));
+           Make_Procedure_Call_Statement (Loc,
+             Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
+             Parameter_Associations => New_List (
+               New_Reference_To (RTE (RE_Null_Address), Loc),
+               New_Reference_To (DT_Ptr, Loc),
+               New_Occurrence_Of (Standard_True, Loc),
+               Make_Integer_Literal (Loc, Uint_0),
+               New_Reference_To (RTE (RE_Null_Address), Loc))));
+      end if;
 
-         --  Generate code to register the Tag in the External_Tag hash
-         --  table for the pure Ada type only.
+      --  Generate code to register the Tag in the External_Tag hash table for
+      --  the pure Ada type only.
 
-         --        Register_Tag (Dt_Ptr);
+      --        Register_Tag (Dt_Ptr);
 
-         --  Skip this if routine not available, or in No_Run_Time mode
-         --  or Typ is an abstract interface type (because the table to
-         --  register it is not available in the abstract type but in
-         --  types implementing this interface)
+      --  Skip this if routine not available, or in No_Run_Time mode or Typ is
+      --  an abstract interface type (because the table to register it is not
+      --  available in the abstract type but in types implementing this
+      --  interface)
 
-         if not No_Run_Time_Mode
-           and then RTE_Available (RE_Register_Tag)
-           and then Is_RTE (Generalized_Tag, RE_Tag)
-           and then not Is_Interface (Typ)
-         then
-            Append_To (Elab_Code,
-              Make_Procedure_Call_Statement (Loc,
-                Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
-                Parameter_Associations =>
-                  New_List (New_Reference_To (DT_Ptr, Loc))));
-         end if;
+      if not Has_External_Tag_Rep_Clause (Typ)
+        and then not No_Run_Time_Mode
+        and then RTE_Available (RE_Register_Tag)
+        and then Is_RTE (RTE (RE_Tag), RE_Tag)
+        and then not Is_Interface (Typ)
+      then
+         Append_To (Elab_Code,
+           Make_Procedure_Call_Statement (Loc,
+             Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
+             Parameter_Associations =>
+               New_List (New_Reference_To (DT_Ptr, Loc))));
       end if;
 
       --  Generate:
@@ -3422,20 +3336,20 @@ package body Exp_Disp is
           Condition       => New_Reference_To (No_Reg, Loc),
           Then_Statements => Elab_Code));
 
-      --  Ada 2005 (AI-251): Register the tag of the interfaces into
-      --  the table of implemented interfaces.
+      --  Ada 2005 (AI-251): Register the tag of the interfaces into the table
+      --  of interfaces.
 
       if Num_Ifaces > 0 then
          declare
-            Position : Int;
+            Position : Nat;
 
          begin
             --  If the parent is an interface we must generate code to register
             --  all its interfaces; otherwise this code is not needed because
             --  Inherit_TSD has already inherited such interfaces.
 
-            if Etype (Typ) /= Typ
-              and then Is_Interface (Etype (Typ))
+            if Is_Concurrent_Record_Type (Typ)
+              or else (Etype (Typ) /= Typ and then Is_Interface (Etype (Typ)))
             then
                Position := 1;
 
@@ -3553,7 +3467,7 @@ package body Exp_Disp is
    procedure Make_Secondary_DT
      (Typ             : Entity_Id;
       Ancestor_Typ    : Entity_Id;
-      Suffix_Index    : Int;
+      Suffix_Index    : Nat;
       Iface           : Entity_Id;
       AI_Tag          : Entity_Id;
       Acc_Disp_Tables : in out Elist_Id;
@@ -3566,7 +3480,7 @@ package body Exp_Disp is
       Iface_DT        : Node_Id;
       Iface_DT_Ptr    : Node_Id;
       Name_DT_Ptr     : Name_Id;
-      Nb_Prim         : Int;
+      Nb_Prim         : Nat;
       OSD             : Entity_Id;
       Size_Expr_Node  : Node_Id;
       Tname           : Name_Id;
@@ -3613,15 +3527,12 @@ package body Exp_Disp is
 
       Size_Expr_Node :=
         Make_Op_Add (Loc,
-          Left_Opnd  => Make_DT_Access_Action (Etype (AI_Tag),
-                          DT_Prologue_Size,
-                          No_List),
+          Left_Opnd  =>
+            New_Reference_To (RTE (RE_DT_Prologue_Size), Loc),
           Right_Opnd =>
             Make_Op_Multiply (Loc,
               Left_Opnd  =>
-                Make_DT_Access_Action (Etype (AI_Tag),
-                                       DT_Entry_Size,
-                                       No_List),
+                New_Reference_To (RTE (RE_DT_Entry_Size), Loc),
               Right_Opnd =>
                 Make_Integer_Literal (Loc, Nb_Prim)));
 
@@ -3669,8 +3580,7 @@ package body Exp_Disp is
                       Prefix         => New_Reference_To (Iface_DT, Loc),
                       Attribute_Name => Name_Address)),
                 Right_Opnd =>
-                  Make_DT_Access_Action (Etype (AI_Tag),
-                    DT_Prologue_Size, No_List)))));
+                  New_Reference_To (RTE (RE_DT_Prologue_Size), Loc)))));
 
       --  Note: Offset_To_Top will be initialized by the init subprogram
 
@@ -3732,32 +3642,9 @@ package body Exp_Disp is
               Prefix         => New_Reference_To (OSD, Loc),
               Attribute_Name => Name_Address))));
 
-      --  Generate:
-      --    Set_Num_Prim_Ops (T'Tag, Nb_Prim)
-
-      if RTE_Available (RE_Set_Num_Prim_Ops) then
-         if Empty_DT then
-            Append_To (Result,
-              Make_Procedure_Call_Statement (Loc,
-                Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
-                Parameter_Associations => New_List (
-                  Unchecked_Convert_To (RTE (RE_Tag),
-                    New_Reference_To (Iface_DT_Ptr, Loc)),
-                  Make_Integer_Literal (Loc, Uint_0))));
-         else
-            Append_To (Result,
-              Make_Procedure_Call_Statement (Loc,
-                Name => New_Reference_To (RTE (RE_Set_Num_Prim_Ops), Loc),
-                Parameter_Associations => New_List (
-                  Unchecked_Convert_To (RTE (RE_Tag),
-                    New_Reference_To (Iface_DT_Ptr, Loc)),
-                  Make_Integer_Literal (Loc, Nb_Prim))));
-         end if;
-      end if;
-
       if Ada_Version >= Ada_05
-        and then not Is_Interface  (Typ)
-        and then not Is_Abstract   (Typ)
+        and then not Is_Interface (Typ)
+        and then not Is_Abstract_Type (Typ)
         and then not Is_Controlled (Typ)
         and then RTE_Available (RE_Set_Tagged_Kind)
         and then not Restriction_Active (No_Dispatching_Calls)
@@ -3775,10 +3662,7 @@ package body Exp_Disp is
 
          if not Empty_DT
            and then Is_Concurrent_Record_Type (Typ)
-           and then Implements_Interface (
-                      Typ          => Typ,
-                      Kind         => Any_Limited_Interface,
-                      Check_Parent => True)
+           and then Has_Abstract_Interfaces (Typ)
          then
             declare
                Prim       : Entity_Id;
@@ -3839,7 +3723,7 @@ package body Exp_Disp is
       Prim_Als  : Entity_Id;
       Prim_Elmt : Elmt_Id;
       Prim_Pos  : Uint;
-      Nb_Prim   : Int := 0;
+      Nb_Prim   : Nat := 0;
 
       type Examined_Array is array (Int range <>) of Boolean;
 
@@ -4192,482 +4076,345 @@ package body Exp_Disp is
       --  Local variables
 
       Parent_Typ : constant Entity_Id := Etype (Typ);
-      Root_Typ   : constant Entity_Id := Root_Type (Typ);
       First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
       The_Tag    : constant Entity_Id := First_Tag_Component (Typ);
 
       Adjusted   : Boolean := False;
       Finalized  : Boolean := False;
 
-      Count_Prim : Int;
-      DT_Length  : Int;
-      Nb_Prim    : Int;
-      Parent_EC  : Int;
+      Count_Prim : Nat;
+      DT_Length  : Nat;
+      Nb_Prim    : Nat;
       Prim       : Entity_Id;
       Prim_Elmt  : Elmt_Id;
 
    --  Start of processing for Set_All_DT_Position
 
    begin
-      --  Get Entry_Count of the parent
-
-      if Parent_Typ /= Typ
-        and then DT_Entry_Count (First_Tag_Component (Parent_Typ)) /= No_Uint
-      then
-         Parent_EC := UI_To_Int (DT_Entry_Count
-                                   (First_Tag_Component (Parent_Typ)));
-      else
-         Parent_EC := 0;
-      end if;
-
-      --  C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable
-      --  give a coherent set of information
-
-      if Is_CPP_Class (Root_Typ) and then Debug_Flag_QQ then
-
-         --  Compute the number of primitive operations in the main Vtable
-         --  Set their position:
-         --    - where it was set if overriden or inherited
-         --    - after the end of the parent vtable otherwise
-
-         Prim_Elmt := First_Prim;
-         Nb_Prim := 0;
-         while Present (Prim_Elmt) loop
-            Prim := Node (Prim_Elmt);
-
-            if not Is_CPP_Class (Typ) then
-               Set_DTC_Entity (Prim, The_Tag);
-
-            elsif Present (Alias (Prim)) then
-               Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim)));
-               Set_DT_Position (Prim, DT_Position (Alias (Prim)));
+      --  Set the DT_Position for each primitive operation. Perform some
+      --  sanity checks to avoid to build completely inconsistant dispatch
+      --  tables.
 
-            elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then
-                  Error_Msg_NE ("is a primitive operation of&," &
-                    " pragma Cpp_Virtual required", Prim, Typ);
-            end if;
-
-            if DTC_Entity (Prim) = The_Tag then
+      --  First stage: Set the DTC entity of all the primitive operations
+      --  This is required to properly read the DT_Position attribute in
+      --  the latter stages.
 
-               --  Get the slot from the parent subprogram if any
+      Prim_Elmt  := First_Prim;
+      Count_Prim := 0;
+      while Present (Prim_Elmt) loop
+         Prim := Node (Prim_Elmt);
 
-               declare
-                  H : Entity_Id;
+         --  Predefined primitives have a separate dispatch table
 
-               begin
-                  H := Homonym (Prim);
-                  while Present (H) loop
-                     if Present (DTC_Entity (H))
-                       and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ
-                     then
-                        Set_DT_Position (Prim, DT_Position (H));
-                        exit;
-                     end if;
-
-                     H := Homonym (H);
-                  end loop;
-               end;
+         if not (Is_Predefined_Dispatching_Operation (Prim)
+                   or else Is_Predefined_Dispatching_Alias (Prim))
+         then
+            Count_Prim := Count_Prim + 1;
+         end if;
 
-               --  Otherwise take the canonical slot after the end of the
-               --  parent Vtable
+         --  Ada 2005 (AI-251)
 
-               if DT_Position (Prim) = No_Uint then
-                  Nb_Prim := Nb_Prim + 1;
-                  Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim));
-
-               elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then
-                  Nb_Prim := Nb_Prim + 1;
-               end if;
-            end if;
+         if Present (Abstract_Interface_Alias (Prim))
+           and then Is_Interface
+                      (Find_Dispatching_Type
+                        (Abstract_Interface_Alias (Prim)))
+         then
+            Set_DTC_Entity (Prim,
+               Find_Interface_Tag
+                 (T => Typ,
+                  Iface => Find_Dispatching_Type
+                            (Abstract_Interface_Alias (Prim))));
+         else
+            Set_DTC_Entity (Prim, The_Tag);
+         end if;
 
-            Next_Elmt (Prim_Elmt);
-         end loop;
+         --  Clear any previous value of the DT_Position attribute. In this
+         --  way we ensure that the final position of all the primitives is
+         --  stablished by the following stages of this algorithm.
 
-         --  Check that the declared size of the Vtable is bigger or equal
-         --  than the number of primitive operations (if bigger it means that
-         --  some of the c++ virtual functions were not imported, that is
-         --  allowed).
+         Set_DT_Position (Prim, No_Uint);
 
-         if DT_Entry_Count (The_Tag) = No_Uint
-           or else not Is_CPP_Class (Typ)
-         then
-            Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim));
+         Next_Elmt (Prim_Elmt);
+      end loop;
 
-         elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then
-            Error_Msg_N ("not enough room in the Vtable for all virtual"
-              & " functions", The_Tag);
-         end if;
+      declare
+         Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean
+                        := (others => False);
+         E : Entity_Id;
 
-         --  Check that Positions are not duplicate nor outside the range of
-         --  the Vtable.
+         procedure Set_Fixed_Prim (Pos : Nat);
+         --  Sets to true an element of the Fixed_Prim table to indicate
+         --  that this entry of the dispatch table of Typ is occupied.
 
-         declare
-            Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag));
-            Pos  : Int;
-            Prim_Pos_Table : array (1 .. Size) of Entity_Id :=
-                                                        (others => Empty);
+         --------------------
+         -- Set_Fixed_Prim --
+         --------------------
 
+         procedure Set_Fixed_Prim (Pos : Nat) is
          begin
-            Prim_Elmt := First_Prim;
-            while Present (Prim_Elmt) loop
-               Prim := Node (Prim_Elmt);
+            pragma Assert (Pos >= 0 and then Pos <= Count_Prim);
+            Fixed_Prim (Pos) := True;
+         exception
+            when Constraint_Error =>
+               raise Program_Error;
+         end Set_Fixed_Prim;
 
-               if DTC_Entity (Prim) = The_Tag then
-                  Pos := UI_To_Int (DT_Position (Prim));
+      begin
+         --  Second stage: Register fixed entries
 
-                  if Pos not in Prim_Pos_Table'Range then
-                     Error_Msg_N
-                       ("position not in range of virtual table", Prim);
+         Nb_Prim   := 0;
+         Prim_Elmt := First_Prim;
+         while Present (Prim_Elmt) loop
+            Prim := Node (Prim_Elmt);
 
-                  elsif Present (Prim_Pos_Table (Pos)) then
-                     Error_Msg_NE ("cannot be at the same position in the"
-                       & " vtable than&", Prim, Prim_Pos_Table (Pos));
+            --  Predefined primitives have a separate table and all its
+            --  entries are at predefined fixed positions.
 
-                  else
-                     Prim_Pos_Table (Pos) := Prim;
-                  end if;
-               end if;
+            if Is_Predefined_Dispatching_Operation (Prim) then
+               Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
 
-               Next_Elmt (Prim_Elmt);
-            end loop;
-         end;
-
-         --  Generate listing showing the contents of the dispatch tables
+            elsif Is_Predefined_Dispatching_Alias (Prim) then
+               E := Alias (Prim);
+               while Present (Alias (E)) loop
+                  E := Alias (E);
+               end loop;
 
-         if Debug_Flag_ZZ then
-            Write_DT (Typ);
-         end if;
+               Set_DT_Position (Prim, Default_Prim_Op_Position (E));
 
-      --  For regular Ada tagged types, just set the DT_Position for
-      --  each primitive operation. Perform some sanity checks to avoid
-      --  to build completely inconsistant dispatch tables.
+            --  Overriding primitives of ancestor abstract interfaces
 
-      --  Note that the _Size primitive is always set at position 1 in order
-      --  to comply with the needs of Ada.Tags.Parent_Size (see documentation
-      --  in Ada.Tags).
+            elsif Present (Abstract_Interface_Alias (Prim))
+              and then Is_Parent
+                         (Find_Dispatching_Type
+                           (Abstract_Interface_Alias (Prim)),
+                          Typ)
+            then
+               pragma Assert (DT_Position (Prim) = No_Uint
+                 and then Present (DTC_Entity
+                                    (Abstract_Interface_Alias (Prim))));
 
-      else
-         --  First stage: Set the DTC entity of all the primitive operations
-         --  This is required to properly read the DT_Position attribute in
-         --  the latter stages.
+               E := Abstract_Interface_Alias (Prim);
+               Set_DT_Position (Prim, DT_Position (E));
 
-         Prim_Elmt  := First_Prim;
-         Count_Prim := 0;
-         while Present (Prim_Elmt) loop
-            Prim := Node (Prim_Elmt);
+               pragma Assert
+                 (DT_Position (Alias (Prim)) = No_Uint
+                    or else DT_Position (Alias (Prim)) = DT_Position (E));
+               Set_DT_Position (Alias (Prim), DT_Position (E));
+               Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
 
-            --  Predefined primitives have a separate dispatch table
+            --  Overriding primitives must use the same entry as the
+            --  overriden primitive
 
-            if not (Is_Predefined_Dispatching_Operation (Prim)
-                      or else Is_Predefined_Dispatching_Alias (Prim))
+            elsif not Present (Abstract_Interface_Alias (Prim))
+              and then Present (Alias (Prim))
+              and then Find_Dispatching_Type (Alias (Prim)) /= Typ
+              and then Is_Parent
+                         (Find_Dispatching_Type (Alias (Prim)), Typ)
+              and then Present (DTC_Entity (Alias (Prim)))
             then
-               Count_Prim := Count_Prim + 1;
-            end if;
-
-            --  Ada 2005 (AI-251)
+               E := Alias (Prim);
+               Set_DT_Position (Prim, DT_Position (E));
 
-            if Present (Abstract_Interface_Alias (Prim))
-              and then Is_Interface
-                         (Find_Dispatching_Type
-                           (Abstract_Interface_Alias (Prim)))
-            then
-               Set_DTC_Entity (Prim,
-                  Find_Interface_Tag
-                    (T => Typ,
-                     Iface => Find_Dispatching_Type
-                               (Abstract_Interface_Alias (Prim))));
-            else
-               Set_DTC_Entity (Prim, The_Tag);
+               if not Is_Predefined_Dispatching_Alias (E) then
+                  Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
+               end if;
             end if;
 
-            --  Clear any previous value of the DT_Position attribute. In this
-            --  way we ensure that the final position of all the primitives is
-            --  stablished by the following stages of this algorithm.
-
-            Set_DT_Position (Prim, No_Uint);
-
             Next_Elmt (Prim_Elmt);
          end loop;
 
-         declare
-            Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean
-                           := (others => False);
-            E : Entity_Id;
+         --  Third stage: Fix the position of all the new primitives
+         --  Entries associated with primitives covering interfaces
+         --  are handled in a latter round.
 
-            procedure Set_Fixed_Prim (Pos : Int);
-            --  Sets to true an element of the Fixed_Prim table to indicate
-            --  that this entry of the dispatch table of Typ is occupied.
-
-            --------------------
-            -- Set_Fixed_Prim --
-            --------------------
-
-            procedure Set_Fixed_Prim (Pos : Int) is
-            begin
-               pragma Assert (Pos >= 0 and then Pos <= Count_Prim);
-               Fixed_Prim (Pos) := True;
-            exception
-               when Constraint_Error =>
-                  raise Program_Error;
-            end Set_Fixed_Prim;
-
-         begin
-            --  Second stage: Register fixed entries
-
-            Nb_Prim   := 0;
-            Prim_Elmt := First_Prim;
-            while Present (Prim_Elmt) loop
-               Prim := Node (Prim_Elmt);
-
-               --  Predefined primitives have a separate table and all its
-               --  entries are at predefined fixed positions.
-
-               if Is_Predefined_Dispatching_Operation (Prim) then
-                  Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
-
-               elsif Is_Predefined_Dispatching_Alias (Prim) then
-                  E := Alias (Prim);
-                  while Present (Alias (E)) loop
-                     E := Alias (E);
-                  end loop;
-
-                  Set_DT_Position (Prim, Default_Prim_Op_Position (E));
-
-               --  Overriding primitives of ancestor abstract interfaces
-
-               elsif Present (Abstract_Interface_Alias (Prim))
-                 and then Is_Ancestor
-                           (Find_Dispatching_Type
-                             (Abstract_Interface_Alias (Prim)),
-                            Typ)
-               then
-                  pragma Assert (DT_Position (Prim) = No_Uint
-                    and then Present (DTC_Entity
-                                       (Abstract_Interface_Alias (Prim))));
-
-                  E := Abstract_Interface_Alias (Prim);
-                  Set_DT_Position (Prim, DT_Position (E));
-
-                  pragma Assert
-                    (DT_Position (Alias (Prim)) = No_Uint
-                       or else DT_Position (Alias (Prim)) = DT_Position (E));
-                  Set_DT_Position (Alias (Prim), DT_Position (E));
-                  Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
-
-               --  Overriding primitives must use the same entry as the
-               --  overriden primitive
-
-               elsif not Present (Abstract_Interface_Alias (Prim))
-                 and then Present (Alias (Prim))
-                 and then Find_Dispatching_Type (Alias (Prim)) /= Typ
-                 and then Is_Ancestor
-                            (Find_Dispatching_Type (Alias (Prim)), Typ)
-                 and then Present (DTC_Entity (Alias (Prim)))
-               then
-                  E := Alias (Prim);
-                  Set_DT_Position (Prim, DT_Position (E));
+         Prim_Elmt := First_Prim;
+         while Present (Prim_Elmt) loop
+            Prim := Node (Prim_Elmt);
 
-                  if not Is_Predefined_Dispatching_Alias (E) then
-                     Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
-                  end if;
-               end if;
+            --  Skip primitives previously set entries
 
-               Next_Elmt (Prim_Elmt);
-            end loop;
-
-            --  Third stage: Fix the position of all the new primitives
-            --  Entries associated with primitives covering interfaces
-            --  are handled in a latter round.
+            if DT_Position (Prim) /= No_Uint then
+               null;
 
-            Prim_Elmt := First_Prim;
-            while Present (Prim_Elmt) loop
-               Prim := Node (Prim_Elmt);
+            --  Primitives covering interface primitives are handled later
 
-               --  Skip primitives previously set entries
+            elsif Present (Abstract_Interface_Alias (Prim)) then
+               null;
 
-               if DT_Position (Prim) /= No_Uint then
-                  null;
+            else
+               --  Take the next available position in the DT
 
-               --  Primitives covering interface primitives are handled later
+               loop
+                  Nb_Prim := Nb_Prim + 1;
+                  pragma Assert (Nb_Prim <= Count_Prim);
+                  exit when not Fixed_Prim (Nb_Prim);
+               end loop;
 
-               elsif Present (Abstract_Interface_Alias (Prim)) then
-                  null;
+               Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
+               Set_Fixed_Prim (Nb_Prim);
+            end if;
 
-               else
-                  --  Take the next available position in the DT
+            Next_Elmt (Prim_Elmt);
+         end loop;
+      end;
 
-                  loop
-                     Nb_Prim := Nb_Prim + 1;
-                     pragma Assert (Nb_Prim <= Count_Prim);
-                     exit when not Fixed_Prim (Nb_Prim);
-                  end loop;
+      --  Fourth stage: Complete the decoration of primitives covering
+      --  interfaces (that is, propagate the DT_Position attribute
+      --  from the aliased primitive)
 
-                  Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
-                  Set_Fixed_Prim (Nb_Prim);
-               end if;
+      Prim_Elmt := First_Prim;
+      while Present (Prim_Elmt) loop
+         Prim := Node (Prim_Elmt);
 
-               Next_Elmt (Prim_Elmt);
-            end loop;
-         end;
+         if DT_Position (Prim) = No_Uint
+           and then Present (Abstract_Interface_Alias (Prim))
+         then
+            pragma Assert (Present (Alias (Prim))
+              and then Find_Dispatching_Type (Alias (Prim)) = Typ);
 
-         --  Fourth stage: Complete the decoration of primitives covering
-         --  interfaces (that is, propagate the DT_Position attribute
-         --  from the aliased primitive)
+            --  Check if this entry will be placed in the primary DT
 
-         Prim_Elmt := First_Prim;
-         while Present (Prim_Elmt) loop
-            Prim := Node (Prim_Elmt);
-
-            if DT_Position (Prim) = No_Uint
-              and then Present (Abstract_Interface_Alias (Prim))
+            if Is_Parent (Find_Dispatching_Type
+                           (Abstract_Interface_Alias (Prim)),
+                          Typ)
             then
-               pragma Assert (Present (Alias (Prim))
-                 and then Find_Dispatching_Type (Alias (Prim)) = Typ);
-
-               --  Check if this entry will be placed in the primary DT
-
-               if Is_Ancestor (Find_Dispatching_Type
-                                 (Abstract_Interface_Alias (Prim)),
-                               Typ)
-               then
-                  pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
-                  Set_DT_Position (Prim, DT_Position (Alias (Prim)));
+               pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
+               Set_DT_Position (Prim, DT_Position (Alias (Prim)));
 
-               --  Otherwise it will be placed in the secondary DT
+            --  Otherwise it will be placed in the secondary DT
 
-               else
-                  pragma Assert
-                    (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
-                  Set_DT_Position (Prim,
-                    DT_Position (Abstract_Interface_Alias (Prim)));
-               end if;
+            else
+               pragma Assert
+                 (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
+               Set_DT_Position (Prim,
+                 DT_Position (Abstract_Interface_Alias (Prim)));
             end if;
+         end if;
 
-            Next_Elmt (Prim_Elmt);
-         end loop;
-
-         --  Generate listing showing the contents of the dispatch tables.
-         --  This action is done before some further static checks because
-         --  in case of critical errors caused by a wrong dispatch table
-         --  we need to see the contents of such table.
+         Next_Elmt (Prim_Elmt);
+      end loop;
 
-         if Debug_Flag_ZZ then
-            Write_DT (Typ);
-         end if;
+      --  Generate listing showing the contents of the dispatch tables.
+      --  This action is done before some further static checks because
+      --  in case of critical errors caused by a wrong dispatch table
+      --  we need to see the contents of such table.
 
-         --  Final stage: Ensure that the table is correct plus some further
-         --  verifications concerning the primitives.
+      if Debug_Flag_ZZ then
+         Write_DT (Typ);
+      end if;
 
-         Prim_Elmt := First_Prim;
-         DT_Length := 0;
-         while Present (Prim_Elmt) loop
-            Prim := Node (Prim_Elmt);
+      --  Final stage: Ensure that the table is correct plus some further
+      --  verifications concerning the primitives.
 
-            --  At this point all the primitives MUST have a position
-            --  in the dispatch table
+      Prim_Elmt := First_Prim;
+      DT_Length := 0;
+      while Present (Prim_Elmt) loop
+         Prim := Node (Prim_Elmt);
 
-            if DT_Position (Prim) = No_Uint then
-               raise Program_Error;
-            end if;
+         --  At this point all the primitives MUST have a position
+         --  in the dispatch table
 
-            --  Calculate real size of the dispatch table
+         if DT_Position (Prim) = No_Uint then
+            raise Program_Error;
+         end if;
 
-            if not (Is_Predefined_Dispatching_Operation (Prim)
-                      or else Is_Predefined_Dispatching_Alias (Prim))
-              and then UI_To_Int (DT_Position (Prim)) > DT_Length
-            then
-               DT_Length := UI_To_Int (DT_Position (Prim));
-            end if;
+         --  Calculate real size of the dispatch table
 
-            --  Ensure that the asignated position to non-predefined
-            --  dispatching operations in the dispatch table is correct.
+         if not (Is_Predefined_Dispatching_Operation (Prim)
+                   or else Is_Predefined_Dispatching_Alias (Prim))
+           and then UI_To_Int (DT_Position (Prim)) > DT_Length
+         then
+            DT_Length := UI_To_Int (DT_Position (Prim));
+         end if;
 
-            if not (Is_Predefined_Dispatching_Operation (Prim)
-                      or else Is_Predefined_Dispatching_Alias (Prim))
-            then
-               Validate_Position (Prim);
-            end if;
+         --  Ensure that the asignated position to non-predefined
+         --  dispatching operations in the dispatch table is correct.
 
-            if Chars (Prim) = Name_Finalize then
-               Finalized := True;
-            end if;
+         if not (Is_Predefined_Dispatching_Operation (Prim)
+                   or else Is_Predefined_Dispatching_Alias (Prim))
+         then
+            Validate_Position (Prim);
+         end if;
 
-            if Chars (Prim) = Name_Adjust then
-               Adjusted := True;
-            end if;
+         if Chars (Prim) = Name_Finalize then
+            Finalized := True;
+         end if;
 
-            --  An abstract operation cannot be declared in the private part
-            --  for a visible abstract type, because it could never be over-
-            --  ridden. For explicit declarations this is checked at the
-            --  point of declaration, but for inherited operations it must
-            --  be done when building the dispatch table.
+         if Chars (Prim) = Name_Adjust then
+            Adjusted := True;
+         end if;
 
-            --  Ada 2005 (AI-251): Hidden entities associated with abstract
-            --  interface primitives are not taken into account because the
-            --  check is done with the aliased primitive.
+         --  An abstract operation cannot be declared in the private part
+         --  for a visible abstract type, because it could never be over-
+         --  ridden. For explicit declarations this is checked at the
+         --  point of declaration, but for inherited operations it must
+         --  be done when building the dispatch table.
+
+         --  Ada 2005 (AI-251): Hidden entities associated with abstract
+         --  interface primitives are not taken into account because the
+         --  check is done with the aliased primitive.
+
+         if Is_Abstract_Type (Typ)
+           and then Is_Abstract_Subprogram (Prim)
+           and then Present (Alias (Prim))
+           and then not Present (Abstract_Interface_Alias (Prim))
+           and then Is_Derived_Type (Typ)
+           and then In_Private_Part (Current_Scope)
+           and then
+             List_Containing (Parent (Prim)) =
+               Private_Declarations
+                (Specification (Unit_Declaration_Node (Current_Scope)))
+           and then Original_View_In_Visible_Part (Typ)
+         then
+            --  We exclude Input and Output stream operations because
+            --  Limited_Controlled inherits useless Input and Output
+            --  stream operations from Root_Controlled, which can
+            --  never be overridden.
 
-            if Is_Abstract (Typ)
-              and then Is_Abstract (Prim)
-              and then Present (Alias (Prim))
-              and then not Present (Abstract_Interface_Alias (Prim))
-              and then Is_Derived_Type (Typ)
-              and then In_Private_Part (Current_Scope)
-              and then
-                List_Containing (Parent (Prim)) =
-                  Private_Declarations
-                   (Specification (Unit_Declaration_Node (Current_Scope)))
-              and then Original_View_In_Visible_Part (Typ)
+            if not Is_TSS (Prim, TSS_Stream_Input)
+                 and then
+               not Is_TSS (Prim, TSS_Stream_Output)
             then
-               --  We exclude Input and Output stream operations because
-               --  Limited_Controlled inherits useless Input and Output
-               --  stream operations from Root_Controlled, which can
-               --  never be overridden.
-
-               if not Is_TSS (Prim, TSS_Stream_Input)
-                    and then
-                  not Is_TSS (Prim, TSS_Stream_Output)
-               then
-                  Error_Msg_NE
-                    ("abstract inherited private operation&" &
-                     " must be overridden ('R'M 3.9.3(10))",
-                    Parent (Typ), Prim);
-               end if;
+               Error_Msg_NE
+                 ("abstract inherited private operation&" &
+                  " must be overridden ('R'M 3.9.3(10))",
+                 Parent (Typ), Prim);
             end if;
+         end if;
 
-            Next_Elmt (Prim_Elmt);
-         end loop;
+         Next_Elmt (Prim_Elmt);
+      end loop;
 
-         --  Additional check
+      --  Additional check
 
-         if Is_Controlled (Typ) then
-            if not Finalized then
-               Error_Msg_N
-                 ("controlled type has no explicit Finalize method?", Typ);
+      if Is_Controlled (Typ) then
+         if not Finalized then
+            Error_Msg_N
+              ("controlled type has no explicit Finalize method?", Typ);
 
-            elsif not Adjusted then
-               Error_Msg_N
-                 ("controlled type has no explicit Adjust method?", Typ);
-            end if;
+         elsif not Adjusted then
+            Error_Msg_N
+              ("controlled type has no explicit Adjust method?", Typ);
          end if;
+      end if;
 
-         --  Set the final size of the Dispatch Table
+      --  Set the final size of the Dispatch Table
 
-         Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
+      Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
 
-         --  The derived type must have at least as many components as its
-         --  parent (for root types, the Etype points back to itself
-         --  and the test should not fail)
+      --  The derived type must have at least as many components as its
+      --  parent (for root types, the Etype points back to itself
+      --  and the test should not fail)
 
-         --  This test fails compiling the partial view of a tagged type
-         --  derived from an interface which defines the overriding subprogram
-         --  in the private part. This needs further investigation???
+      --  This test fails compiling the partial view of a tagged type
+      --  derived from an interface which defines the overriding subprogram
+      --  in the private part. This needs further investigation???
 
-         if not Has_Private_Declaration (Typ) then
-            pragma Assert (
-              DT_Entry_Count (The_Tag) >=
-              DT_Entry_Count (First_Tag_Component (Parent_Typ)));
-            null;
-         end if;
+      if not Has_Private_Declaration (Typ) then
+         pragma Assert (
+           DT_Entry_Count (The_Tag) >=
+           DT_Entry_Count (First_Tag_Component (Parent_Typ)));
+         null;
       end if;
    end Set_All_DT_Position;
 
@@ -4719,7 +4466,7 @@ package body Exp_Disp is
       --  won't be able to declare objects of that type.
 
       else
-         Set_Is_Abstract (Typ);
+         Set_Is_Abstract_Type (Typ);
       end if;
    end Set_Default_Constructor;
 
@@ -4737,7 +4484,7 @@ package body Exp_Disp is
 
       --  Abstract kinds
 
-      if Is_Abstract (T) then
+      if Is_Abstract_Type (T) then
          if Is_Limited_Record (T) then
             return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
          else
@@ -4862,7 +4609,7 @@ package body Exp_Disp is
             Write_Int (UI_To_Int (DT_Position (Prim)));
          end if;
 
-         if Is_Abstract (Prim) then
+         if Is_Abstract_Subprogram (Prim) then
             Write_Str (" is abstract;");
 
          --  Check if this is a null primitive

gcc/ada/exp_disp.ads

@@ -168,46 +168,24 @@ package Exp_Disp is
    --    Exp_Disp.Set_All_DT_Position      - direct   use
 
    type DT_Access_Action is
-      (CW_Membership,
-       IW_Membership,
-       DT_Entry_Size,
-       DT_Prologue_Size,
-       Get_Access_Level,
+      (IW_Membership,
        Get_Entry_Index,
-       Get_External_Tag,
-       Get_Predefined_Prim_Op_Address,
-       Get_Prim_Op_Address,
        Get_Prim_Op_Kind,
-       Get_RC_Offset,
-       Get_Remotely_Callable,
        Get_Tagged_Kind,
-       Inherit_DT,
-       Inherit_TSD,
        Register_Interface_Tag,
        Register_Tag,
-       Set_Access_Level,
        Set_Entry_Index,
-       Set_Expanded_Name,
-       Set_External_Tag,
-       Set_Interface_Table,
        Set_Offset_Index,
        Set_OSD,
-       Set_Predefined_Prim_Op_Address,
-       Set_Prim_Op_Address,
        Set_Prim_Op_Kind,
-       Set_RC_Offset,
-       Set_Remotely_Callable,
        Set_Signature,
        Set_SSD,
-       Set_TSD,
-       Set_Tagged_Kind,
-       TSD_Entry_Size,
-       TSD_Prologue_Size);
+       Set_Tagged_Kind);
 
    procedure Expand_Dispatching_Call (Call_Node : Node_Id);
    --  Expand the call to the operation through the dispatch table and perform
-   --  the required tag checks when appropriate. For CPP types the call is
-   --  done through the Vtable (tag checks are not relevant)
+   --  the required tag checks when appropriate. For CPP types tag checks are
+   --  not relevant.
 
    procedure Expand_Interface_Actuals (Call_Node : Node_Id);
    --  Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide
@@ -245,15 +223,6 @@ package Exp_Disp is
    --  the secondary dispatch table of Prim's controlling type with Thunk_Id's
    --  address.
 
-   function Get_Remotely_Callable (Obj : Node_Id) return Node_Id;
-   --  Return an expression that holds True if the object can be transmitted
-   --  onto another partition according to E.4 (18)
-
-   function Init_Predefined_Interface_Primitives
-     (Typ : Entity_Id) return List_Id;
-   --  Ada 2005 (AI-251): Initialize the entries associated with predefined
-   --  primitives in all the secondary dispatch tables of Typ.
-
    function Make_DT_Access_Action
      (Typ    : Entity_Id;
       Action : DT_Access_Action;
@@ -333,7 +302,7 @@ package Exp_Disp is
    procedure Make_Secondary_DT
      (Typ             : Entity_Id;
       Ancestor_Typ    : Entity_Id;
-      Suffix_Index    : Int;
+      Suffix_Index    : Nat;
       Iface           : Entity_Id;
       AI_Tag          : Entity_Id;
       Acc_Disp_Tables : in out Elist_Id;

gcc/ada/exp_util.adb

@@ -1303,145 +1303,6 @@ package body Exp_Util is
       end if;
    end Expand_Subtype_From_Expr;
 
-   --------------------------------
-   -- Find_Implemented_Interface --
-   --------------------------------
-
-   --  Given the following code (XXX denotes irrelevant value):
-
-   --     type Limd_Iface is limited interface;
-   --     type Prot_Iface is protected interface;
-   --     type Sync_Iface is synchronized interface;
-
-   --     type Parent_Subtype is new Limd_Iface and Sync_Iface with ...
-   --     type Child_Subtype is new Parent_Subtype and Prot_Iface with ...
-
-   --  The following calls will return the following values:
-
-   --     Find_Implemented_Interface
-   --       (Child_Subtype, Synchronized_Interface, False)    -> Empty
-
-   --     Find_Implemented_Interface
-   --       (Child_Subtype, Synchronized_Interface, True)     -> Sync_Iface
-
-   --     Find_Implemented_Interface
-   --       (Child_Subtype, Any_Synchronized_Interface, XXX)  -> Prot_Iface
-
-   --     Find_Implemented_Interface
-   --       (Child_Subtype, Any_Limited_Interface, XXX)       -> Prot_Iface
-
-   function Find_Implemented_Interface
-     (Typ          : Entity_Id;
-      Kind         : Interface_Kind;
-      Check_Parent : Boolean := False) return Entity_Id
-   is
-      Iface_Elmt : Elmt_Id;
-
-      function Interface_In_Kind
-        (I    : Entity_Id;
-         Kind : Interface_Kind) return Boolean;
-      --  Determine whether an interface falls into a specified kind
-
-      -----------------------
-      -- Interface_In_Kind --
-      -----------------------
-
-      function Interface_In_Kind
-        (I    : Entity_Id;
-         Kind : Interface_Kind) return Boolean is
-      begin
-         if Is_Limited_Interface (I)
-           and then (Kind = Any_Interface
-             or else Kind = Any_Limited_Interface
-             or else Kind = Limited_Interface)
-         then
-            return True;
-
-         elsif Is_Protected_Interface (I)
-           and then (Kind = Any_Interface
-             or else Kind = Any_Limited_Interface
-             or else Kind = Any_Synchronized_Interface
-             or else Kind = Protected_Interface)
-         then
-            return True;
-
-         elsif Is_Synchronized_Interface (I)
-           and then (Kind = Any_Interface
-             or else Kind = Any_Limited_Interface
-             or else Kind = Synchronized_Interface)
-         then
-            return True;
-
-         elsif Is_Task_Interface (I)
-           and then (Kind = Any_Interface
-             or else Kind = Any_Limited_Interface
-             or else Kind = Any_Synchronized_Interface
-             or else Kind = Task_Interface)
-         then
-            return True;
-
-         --  Regular interface. This should be the last kind to check since
-         --  all of the previous cases have their Is_Interface flags set.
-
-         elsif Is_Interface (I)
-           and then (Kind = Any_Interface
-             or else Kind = Iface)
-         then
-            return True;
-
-         else
-            return False;
-         end if;
-      end Interface_In_Kind;
-
-   --  Start of processing for Find_Implemented_Interface
-
-   begin
-      if not Is_Tagged_Type (Typ) then
-         return Empty;
-      end if;
-
-      --  Implementations of the form:
-      --    Typ is new Interface ...
-
-      if Is_Interface (Etype (Typ))
-        and then Interface_In_Kind (Etype (Typ), Kind)
-      then
-         return Etype (Typ);
-      end if;
-
-      --  Implementations of the form:
-      --     Typ is new Typ_Parent and Interface ...
-
-      if Present (Abstract_Interfaces (Typ)) then
-         Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ));
-         while Present (Iface_Elmt) loop
-            if Interface_In_Kind (Node (Iface_Elmt), Kind) then
-               return Node (Iface_Elmt);
-            end if;
-
-            Iface_Elmt := Next_Elmt (Iface_Elmt);
-         end loop;
-      end if;
-
-      --  Typ is a derived type and may implement a limited interface
-      --  through its parent subtype. Check the parent subtype as well
-      --  as any interfaces explicitly implemented at this level.
-
-      if Check_Parent
-        and then Ekind (Typ) = E_Record_Type
-        and then Present (Parent_Subtype (Typ))
-      then
-         return Find_Implemented_Interface (
-           Parent_Subtype (Typ), Kind, Check_Parent);
-      end if;
-
-      --  Typ does not implement a limited interface either at this level or
-      --  in any of its parent subtypes.
-
-      return Empty;
-   end Find_Implemented_Interface;
-
    ------------------------
    -- Find_Interface_ADT --
    ------------------------
@@ -1466,9 +1327,22 @@ package body Exp_Util is
          AI      : Node_Id;
 
       begin
-         --  Climb to the ancestor (if any) handling private types
+         pragma Assert (Typ /= Iface);
+
+         --  Climb to the ancestor (if any) handling synchronized interface
+         --  derivations and private types
+
+         if Is_Concurrent_Record_Type (Typ) then
+            declare
+               Iface_List : constant List_Id := Abstract_Interface_List (Typ);
+
+            begin
+               if Is_Non_Empty_List (Iface_List) then
+                  Find_Secondary_Table (Etype (First (Iface_List)));
+               end if;
+            end;
 
-         if Present (Full_View (Etype (Typ))) then
+         elsif Present (Full_View (Etype (Typ))) then
             if Full_View (Etype (Typ)) /= Typ then
                Find_Secondary_Table (Full_View (Etype (Typ)));
             end if;
@@ -1477,13 +1351,10 @@ package body Exp_Util is
             Find_Secondary_Table (Etype (Typ));
          end if;
 
-         --  If we already found it there is nothing else to do
-
-         if Found then
-            return;
-         end if;
+         --  Traverse the list of interfaces implemented by the type
 
-         if Present (Abstract_Interfaces (Typ))
+         if not Found
+           and then Present (Abstract_Interfaces (Typ))
            and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
          then
             AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
@@ -1501,9 +1372,11 @@ package body Exp_Util is
          end if;
       end Find_Secondary_Table;
 
-   --  Start of processing for Find_Interface_Tag
+   --  Start of processing for Find_Interface_ADT
 
    begin
+      pragma Assert (Is_Interface (Iface));
+
       --  Handle private types
 
       if Has_Private_Declaration (Typ)
@@ -1520,12 +1393,14 @@ package body Exp_Util is
 
       --  Handle task and protected types implementing interfaces
 
-      if Ekind (Typ) = E_Protected_Type
-        or else Ekind (Typ) = E_Task_Type
-      then
+      if Is_Concurrent_Type (Typ) then
          Typ := Corresponding_Record_Type (Typ);
       end if;
 
+      pragma Assert
+        (not Is_Class_Wide_Type (Typ)
+          and then Ekind (Typ) /= E_Incomplete_Type);
+
       ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
       pragma Assert (Present (Node (ADT)));
       Find_Secondary_Table (Typ);
@@ -1538,13 +1413,21 @@ package body Exp_Util is
    ------------------------
 
    function Find_Interface_Tag
-     (T      : Entity_Id;
-      Iface  : Entity_Id) return Entity_Id
+     (T     : Entity_Id;
+      Iface : Entity_Id) return Entity_Id
    is
       AI_Tag : Entity_Id;
-      Found  : Boolean := False;
+      Found  : Boolean   := False;
       Typ    : Entity_Id := T;
 
+      Is_Primary_Tag : Boolean := False;
+
+      Is_Sync_Typ : Boolean := False;
+      --  In case of non concurrent-record-types each parent-type has the
+      --  tags associated with the interface types that are not implemented
+      --  by the ancestors; concurrent-record-types have their whole list of
+      --  interface tags (and this case requires some special management).
+
       procedure Find_Tag (Typ : Entity_Id);
       --  Internal subprogram used to recursively climb to the ancestors
 
@@ -1561,15 +1444,32 @@ package body Exp_Util is
          --  therefore shares the main tag.
 
          if Typ = Iface then
-            pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
-            AI_Tag := First_Tag_Component (Typ);
+            if Is_Sync_Typ then
+               Is_Primary_Tag := True;
+            else
+               pragma Assert
+                 (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+               AI_Tag := First_Tag_Component (Typ);
+            end if;
+
             Found  := True;
             return;
          end if;
 
+         --  Handle synchronized interface derivations
+
+         if Is_Concurrent_Record_Type (Typ) then
+            declare
+               Iface_List : constant List_Id := Abstract_Interface_List (Typ);
+            begin
+               if Is_Non_Empty_List (Iface_List) then
+                  Find_Tag (Etype (First (Iface_List)));
+               end if;
+            end;
+
          --  Climb to the root type handling private types
 
-         if Present (Full_View (Etype (Typ))) then
+         elsif Present (Full_View (Etype (Typ))) then
             if Full_View (Etype (Typ)) /= Typ then
                Find_Tag (Full_View (Etype (Typ)));
             end if;
@@ -1586,9 +1486,12 @@ package body Exp_Util is
          then
             --  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));
+            if not Is_Sync_Typ then
+               pragma Assert
+                 (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+               AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+               pragma Assert (Present (AI_Tag));
+            end if;
 
             AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
             while Present (AI_Elmt) loop
@@ -1641,9 +1544,25 @@ package body Exp_Util is
          Typ := Non_Limited_View (Typ);
       end if;
 
-      Find_Tag (Typ);
-      pragma Assert (Found);
-      return AI_Tag;
+      if not Is_Concurrent_Record_Type (Typ) then
+         Find_Tag (Typ);
+         pragma Assert (Found);
+         return AI_Tag;
+
+      --  Concurrent record types
+
+      else
+         Is_Sync_Typ := True;
+         AI_Tag      := Next_Tag_Component (First_Tag_Component (Typ));
+         Find_Tag (Typ);
+         pragma Assert (Found);
+
+         if Is_Primary_Tag then
+            return First_Tag_Component (Typ);
+         else
+            return AI_Tag;
+         end if;
+      end if;
    end Find_Interface_Tag;
 
    --------------------
@@ -1659,6 +1578,12 @@ package body Exp_Util is
       Iface  : Entity_Id;
       Typ    : Entity_Id := T;
 
+      Is_Sync_Typ : Boolean := False;
+      --  In case of non concurrent-record-types each parent-type has the
+      --  tags associated with the interface types that are not implemented
+      --  by the ancestors; concurrent-record-types have their whole list of
+      --  interface tags (and this case requires some special management).
+
       procedure Find_Iface (Typ : Entity_Id);
       --  Internal subprogram used to recursively climb to the ancestors
 
@@ -1672,7 +1597,21 @@ package body Exp_Util is
       begin
          --  Climb to the root type
 
-         if Etype (Typ) /= Typ then
+         --  Handle sychronized interface derivations
+
+         if Is_Concurrent_Record_Type (Typ) then
+            declare
+               Iface_List : constant List_Id := Abstract_Interface_List (Typ);
+            begin
+               if Is_Non_Empty_List (Iface_List) then
+                  Find_Iface (Etype (First (Iface_List)));
+               end if;
+            end;
+
+         --  Handle the common case
+
+         elsif Etype (Typ) /= Typ then
+            pragma Assert (not Present (Full_View (Etype (Typ))));
             Find_Iface (Etype (Typ));
          end if;
 
@@ -1684,9 +1623,12 @@ package body Exp_Util is
          then
             --  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));
+            if not Is_Sync_Typ then
+               pragma Assert
+                 (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+               AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+               pragma Assert (Present (AI_Tag));
+            end if;
 
             AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
             while Present (AI_Elmt) loop
@@ -1736,6 +1678,11 @@ package body Exp_Util is
          Typ := Non_Limited_View (Typ);
       end if;
 
+      if Is_Concurrent_Record_Type (Typ) then
+         Is_Sync_Typ := True;
+         AI_Tag      := Next_Tag_Component (First_Tag_Component (Typ));
+      end if;
+
       Find_Iface (Typ);
       pragma Assert (Found);
       return Iface;
@@ -1780,6 +1727,10 @@ package body Exp_Util is
       return Node (Prim);
    end Find_Prim_Op;
 
+   ------------------
+   -- Find_Prim_Op --
+   ------------------
+
    function Find_Prim_Op
      (T    : Entity_Id;
       Name : TSS_Name_Type) return Entity_Id
@@ -2177,18 +2128,6 @@ package body Exp_Util is
       return Count;
    end Homonym_Number;
 
-   --------------------------
-   -- Implements_Interface --
-   --------------------------
-
-   function Implements_Interface
-     (Typ          : Entity_Id;
-      Kind         : Interface_Kind;
-      Check_Parent : Boolean := False) return Boolean is
-   begin
-      return Find_Implemented_Interface (Typ, Kind, Check_Parent) /= Empty;
-   end Implements_Interface;
-
    ------------------------------
    -- In_Unconditional_Context --
    ------------------------------
@@ -2747,10 +2686,16 @@ package body Exp_Util is
                N_Package_Specification                  |
                N_Parameter_Association                  |
                N_Parameter_Specification                |
+               N_Pop_Constraint_Error_Label             |
+               N_Pop_Program_Error_Label                |
+               N_Pop_Storage_Error_Label                |
                N_Pragma_Argument_Association            |
                N_Procedure_Specification                |
                N_Protected_Body                         |
                N_Protected_Definition                   |
+               N_Push_Constraint_Error_Label            |
+               N_Push_Program_Error_Label               |
+               N_Push_Storage_Error_Label               |
                N_Qualified_Expression                   |
                N_Range                                  |
                N_Range_Constraint                       |
@@ -4485,7 +4430,7 @@ package body Exp_Util is
       elsif Nkind (Exp) = N_Unchecked_Type_Conversion
         and then not Safe_Unchecked_Type_Conversion (Exp)
       then
-         if Controlled_Type (Exp_Type) then
+         if CW_Or_Controlled_Type (Exp_Type) then
 
             --  Use a renaming to capture the expression, rather than create
             --  a controlled temporary.
@@ -5124,20 +5069,15 @@ package body Exp_Util is
             E : Entity_Id;
 
          begin
-            E := First_Entity (Typ);
+            E := First_Component_Or_Discriminant (Typ);
             while Present (E) loop
-               if Ekind (E) = E_Component
-                 or else Ekind (E) = E_Discriminant
+               if Component_May_Be_Bit_Aligned (E)
+                 or else Type_May_Have_Bit_Aligned_Components (Etype (E))
                then
-                  if Component_May_Be_Bit_Aligned (E)
-                    or else
-                      Type_May_Have_Bit_Aligned_Components (Etype (E))
-                  then
-                     return True;
-                  end if;
+                  return True;
                end if;
 
-               Next_Entity (E);
+               Next_Component_Or_Discriminant (E);
             end loop;
 
             return False;

gcc/ada/exp_util.ads

@@ -33,21 +33,6 @@ with Types;   use Types;
 
 package Exp_Util is
 
-   --  An enumeration type used to capture all the possible interface
-   --  kinds and their hierarchical relation. These values are used in
-   --  Find_Implemented_Interface and Implements_Interface.
-
-   type Interface_Kind is (
-     Any_Interface,               --  Any interface
-     Any_Limited_Interface,       --  Only limited interfaces
-     Any_Synchronized_Interface,  --  Only synchronized interfaces
-
-     Iface,                       --  Individual kinds
-     Limited_Interface,
-     Protected_Interface,
-     Synchronized_Interface,
-     Task_Interface);
-
    -----------------------------------------------
    -- Handling of Actions Associated with Nodes --
    -----------------------------------------------
@@ -363,16 +348,6 @@ package Exp_Util is
    --  Ada 2005 (AI-251): Given a type T implementing the interface Iface,
    --  return the record component containing the tag of Iface.
 
-   function Find_Implemented_Interface
-     (Typ          : Entity_Id;
-      Kind         : Interface_Kind;
-      Check_Parent : Boolean := False) return Entity_Id;
-   --  Ada 2005 (AI-345): Find a designated kind of interface implemented by
-   --  Typ or any parent subtype. Return the first encountered interface that
-   --  correspond to the selected class. Return Empty if no such interface is
-   --  found. Use Check_Parent to climb a potential derivation chain and
-   --  examine the parent subtypes for any implementation.
-
    function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id;
    --  Find the first primitive operation of type T whose name is 'Name'.
    --  This function allows the use of a primitive operation which is not
@@ -444,14 +419,6 @@ package Exp_Util is
    --  chain, counting only entries in the curren scope. If an entity is not
    --  overloaded, the returned number will be one.
 
-   function Implements_Interface
-     (Typ          : Entity_Id;
-      Kind         : Interface_Kind;
-      Check_Parent : Boolean := False) return Boolean;
-   --  Ada 2005 (AI-345): Determine whether Typ implements a designated kind
-   --  of interface. Use Check_Parent to climb a potential derivation chain
-   --  and examine the parent subtypes for any implementation.
-
    function Inside_Init_Proc return Boolean;
    --  Returns True if current scope is within an init proc
 

gcc/ada/par-ch12.adb

@@ -635,8 +635,7 @@ package body Ch12 is
             return P_Formal_Floating_Point_Definition;
 
          when Tok_Interface => --  Ada 2005 (AI-251)
-            return P_Interface_Type_Definition (Abstract_Present => False,
-                                                Is_Synchronized => False);
+            return P_Interface_Type_Definition (Abstract_Present => False);
 
          when Tok_Left_Paren =>
             return P_Formal_Discrete_Type_Definition;
@@ -646,9 +645,8 @@ package body Ch12 is
             Scan; --  past LIMITED
 
             if Token = Tok_Interface then
-               Typedef_Node := P_Interface_Type_Definition
-                                (Abstract_Present => False,
-                                 Is_Synchronized  => False);
+               Typedef_Node :=
+                 P_Interface_Type_Definition (Abstract_Present => False);
                Set_Limited_Present (Typedef_Node);
                return Typedef_Node;
 
@@ -720,9 +718,8 @@ package body Ch12 is
                --  Interface
 
                else
-                  Typedef_Node := P_Interface_Type_Definition
-                                    (Abstract_Present => False,
-                                     Is_Synchronized  => True);
+                  Typedef_Node :=
+                    P_Interface_Type_Definition (Abstract_Present => False);
 
                   case Saved_Token is
                      when Tok_Task =>

gcc/ada/sem_disp.adb

@@ -204,6 +204,12 @@ package body Sem_Disp is
                Tagged_Type := Base_Type (Designated_Type (T));
             end if;
 
+         --  Ada 2005 : an incomplete type can be tagged. An operation with
+         --  an access parameter of the type is dispatching.
+
+         elsif Scope (Designated_Type (T)) = Current_Scope then
+            Tagged_Type := Designated_Type (T);
+
          --  Ada 2005 (AI-50217)
 
          elsif From_With_Type (Designated_Type (T))
@@ -231,13 +237,13 @@ package body Sem_Disp is
                and then (not Is_Generic_Type (Tagged_Type)
                           or else not Comes_From_Source (Subp)))
         or else
-          (Is_Formal_Subprogram (Subp) and then Is_Abstract (Subp))
+          (Is_Formal_Subprogram (Subp) and then Is_Abstract_Subprogram (Subp))
         or else
           (Nkind (Parent (Parent (Subp))) = N_Subprogram_Renaming_Declaration
             and then
               Present (Corresponding_Formal_Spec (Parent (Parent (Subp))))
             and then
-              Is_Abstract (Subp))
+              Is_Abstract_Subprogram (Subp))
       then
          return Tagged_Type;
 
@@ -274,11 +280,11 @@ package body Sem_Disp is
          Par  : Node_Id;
 
       begin
-         if Is_Abstract (Subp)
+         if Is_Abstract_Subprogram (Subp)
            and then No (Controlling_Argument (N))
          then
             if Present (Alias (Subp))
-              and then not Is_Abstract (Alias (Subp))
+              and then not Is_Abstract_Subprogram (Alias (Subp))
               and then No (DTC_Entity (Subp))
             then
                --  Private overriding of inherited abstract operation,
@@ -428,6 +434,7 @@ package body Sem_Disp is
             --  Mark call as a dispatching call
 
             Set_Controlling_Argument (N, Control);
+            Check_Restriction (No_Dispatching_Calls, N);
 
             --  Ada 2005 (AI-318-02): Check current implementation restriction
             --  that a dispatching call cannot be made to a primitive function
@@ -481,7 +488,7 @@ package body Sem_Disp is
                            (Expression (Original_Node (Actual)))));
                   end if;
 
-                  if Present (Func) and then Is_Abstract (Func) then
+                  if Present (Func) and then Is_Abstract_Subprogram (Func) then
                      Error_Msg_N (
                        "call to abstract function must be dispatching", N);
                   end if;
@@ -1080,7 +1087,8 @@ package body Sem_Disp is
                --  a descendant type and inherits a nonabstract version.
 
                if Etype (Subp) /= Tagged_Type then
-                  Set_Is_Abstract (Old_Subp, Is_Abstract (Alias (Subp)));
+                  Set_Is_Abstract_Subprogram
+                    (Old_Subp, Is_Abstract_Subprogram (Alias (Subp)));
                end if;
             end if;
          end if;
@@ -1315,7 +1323,8 @@ package body Sem_Disp is
       then
          --  Ada 2005 (AI-251): Update the attribute alias of all the aliased
          --  entities of the overriden primitive to reference New_Op, and also
-         --  propagate them the new value of the attribute Is_Abstract.
+         --  propagate them the new value of the attribute
+         --  Is_Abstract_Subprogram.
 
          Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
          while Present (Elmt) loop
@@ -1328,12 +1337,13 @@ package body Sem_Disp is
               and then Alias (Prim) = Prev_Op
             then
                Set_Alias (Prim, New_Op);
-               Set_Is_Abstract (Prim, Is_Abstract (New_Op));
+               Set_Is_Abstract_Subprogram
+                 (Prim, Is_Abstract_Subprogram (New_Op));
 
                --  Ensure that this entity will be expanded to fill the
                --  corresponding entry in its dispatch table.
 
-               if not Is_Abstract (Prim) then
+               if not Is_Abstract_Subprogram (Prim) then
                   Set_Has_Delayed_Freeze (Prim);
                end if;
             end if;

gcc/ada/sem_elab.adb

@@ -2443,15 +2443,13 @@ package body Sem_Elab is
                      Chars (Subp) = Name_Initialize
                        and then Comes_From_Source (Subp)
                        and then Present (Parameter_Associations (Call))
-                       and then Is_Controlled
-                         (Etype (First (Parameter_Associations (Call))));
+                       and then Is_Controlled (Etype (First_Actual (Call)));
    begin
       --  If the unit is mentioned in a with_clause of the current
       --  unit, it is visible, and we can set the elaboration flag.
 
       if Is_Immediately_Visible (Scop)
-        or else
-          (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop))
+        or else (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop))
       then
          Activate_Elaborate_All_Desirable (Call, Scop);
          Set_Suppress_Elaboration_Warnings (Scop, True);
@@ -2482,10 +2480,10 @@ package body Sem_Elab is
       if Is_Init_Proc (Subp)
         or else Init_Call
       then
-         --  The initialization call is on an object whose type is not
-         --  declared in the same scope as the subprogram. The type of
-         --  the object must be a subtype of the type of operation. This
-         --  object is the first actual in the call.
+         --  The initialization call is on an object whose type is not declared
+         --  in the same scope as the subprogram. The type of the object must
+         --  be a subtype of the type of operation. This object is the first
+         --  actual in the call.
 
          declare
             Typ : constant Entity_Id :=