exp_disp.adb   [plain text]

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             E X P _ D I S P                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-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 Checks;   use Checks;
with Debug;    use Debug;
with Einfo;    use Einfo;
with Elists;   use Elists;
with Errout;   use Errout;
with Exp_Ch7;  use Exp_Ch7;
with Exp_Dbug; use Exp_Dbug;
with Exp_Tss;  use Exp_Tss;
with Exp_Util; use Exp_Util;
with Itypes;   use Itypes;
with Nlists;   use Nlists;
with Nmake;    use Nmake;
with Namet;    use Namet;
with Opt;      use Opt;
with Output;   use Output;
with Restrict; use Restrict;
with Rident;   use Rident;
with Rtsfind;  use Rtsfind;
with Sem;      use Sem;
with Sem_Disp; use Sem_Disp;
with Sem_Res;  use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo;    use Sinfo;
with Snames;   use Snames;
with Stand;    use Stand;
with Tbuild;   use Tbuild;
with Uintp;    use Uintp;

package body Exp_Disp is

   --------------------------------
   -- Select_Expansion_Utilities --
   --------------------------------

   --  The following package contains helper routines used in the expansion of
   --  dispatching asynchronous, conditional and timed selects.

   package Select_Expansion_Utilities is
      procedure Build_B
        (Loc    : Source_Ptr;
         Params : List_Id);
      --  Generate:
      --    B : out Communication_Block

      procedure Build_C
        (Loc    : Source_Ptr;
         Params : List_Id);
      --  Generate:
      --    C : out Prim_Op_Kind

      procedure Build_Common_Dispatching_Select_Statements
        (Loc    : Source_Ptr;
         Typ    : Entity_Id;
         DT_Ptr : Entity_Id;
         Stmts  : List_Id);
      --  Ada 2005 (AI-345): Generate statements that are common between
      --  asynchronous, conditional and timed select expansion.

      procedure Build_F
        (Loc    : Source_Ptr;
         Params : List_Id);
      --  Generate:
      --    F : out Boolean

      procedure Build_P
        (Loc    : Source_Ptr;
         Params : List_Id);
      --  Generate:
      --    P : Address

      procedure Build_S
        (Loc    : Source_Ptr;
         Params : List_Id);
      --  Generate:
      --    S : Integer

      procedure Build_T
        (Loc    : Source_Ptr;
         Typ    : Entity_Id;
         Params : List_Id);
      --  Generate:
      --    T : in out Typ
   end Select_Expansion_Utilities;

   package body Select_Expansion_Utilities is

      -------------
      -- Build_B --
      -------------

      procedure Build_B
        (Loc    : Source_Ptr;
         Params : List_Id)
      is
      begin
         Append_To (Params,
           Make_Parameter_Specification (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc, Name_uB),
             Parameter_Type =>
               New_Reference_To (RTE (RE_Communication_Block), Loc),
             Out_Present => True));
      end Build_B;

      -------------
      -- Build_C --
      -------------

      procedure Build_C
        (Loc    : Source_Ptr;
         Params : List_Id)
      is
      begin
         Append_To (Params,
           Make_Parameter_Specification (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc, Name_uC),
             Parameter_Type =>
               New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
             Out_Present => True));
      end Build_C;

      ------------------------------------------------
      -- Build_Common_Dispatching_Select_Statements --
      ------------------------------------------------

      procedure Build_Common_Dispatching_Select_Statements
        (Loc   : Source_Ptr;
         Typ   : Entity_Id;
         DT_Ptr : Entity_Id;
         Stmts : List_Id)
      is
      begin
         --  Generate:
         --    C := get_prim_op_kind (tag! (<type>VP), S);

         --  where C is the out parameter capturing the call kind and S is the
         --  dispatch table slot number.

         Append_To (Stmts,
           Make_Assignment_Statement (Loc,
             Name =>
               Make_Identifier (Loc, Name_uC),
             Expression =>
               Make_DT_Access_Action (Typ,
                 Action =>
                   Get_Prim_Op_Kind,
                 Args =>
                   New_List (
                     Unchecked_Convert_To (RTE (RE_Tag),
                       New_Reference_To (DT_Ptr, Loc)),
                     Make_Identifier (Loc, Name_uS)))));

         --  Generate:

         --    if C = POK_Procedure
         --      or else C = POK_Protected_Procedure
         --      or else C = POK_Task_Procedure;
         --    then
         --       F := True;
         --       return;

         --  where F is the out parameter capturing the status of a potential
         --  entry call.

         Append_To (Stmts,
           Make_If_Statement (Loc,

             Condition =>
               Make_Or_Else (Loc,
                 Left_Opnd =>
                   Make_Op_Eq (Loc,
                     Left_Opnd =>
                       Make_Identifier (Loc, Name_uC),
                     Right_Opnd =>
                       New_Reference_To (RTE (RE_POK_Procedure), Loc)),
                 Right_Opnd =>
                   Make_Or_Else (Loc,
                     Left_Opnd =>
                       Make_Op_Eq (Loc,
                         Left_Opnd =>
                           Make_Identifier (Loc, Name_uC),
                         Right_Opnd =>
                           New_Reference_To (RTE (
                             RE_POK_Protected_Procedure), Loc)),
                     Right_Opnd =>
                       Make_Op_Eq (Loc,
                         Left_Opnd =>
                           Make_Identifier (Loc, Name_uC),
                         Right_Opnd =>
                           New_Reference_To (RTE (
                             RE_POK_Task_Procedure), Loc)))),

             Then_Statements =>
               New_List (
                 Make_Assignment_Statement (Loc,
                   Name       => Make_Identifier (Loc, Name_uF),
                   Expression => New_Reference_To (Standard_True, Loc)),

                 Make_Return_Statement (Loc))));
      end Build_Common_Dispatching_Select_Statements;

      -------------
      -- Build_F --
      -------------

      procedure Build_F
        (Loc    : Source_Ptr;
         Params : List_Id)
      is
      begin
         Append_To (Params,
           Make_Parameter_Specification (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc, Name_uF),
             Parameter_Type =>
               New_Reference_To (Standard_Boolean, Loc),
             Out_Present => True));
      end Build_F;

      -------------
      -- Build_P --
      -------------

      procedure Build_P
        (Loc    : Source_Ptr;
         Params : List_Id)
      is
      begin
         Append_To (Params,
           Make_Parameter_Specification (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc, Name_uP),
             Parameter_Type =>
               New_Reference_To (RTE (RE_Address), Loc)));
      end Build_P;

      -------------
      -- Build_S --
      -------------

      procedure Build_S
        (Loc    : Source_Ptr;
         Params : List_Id)
      is
      begin
         Append_To (Params,
           Make_Parameter_Specification (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc, Name_uS),
             Parameter_Type =>
               New_Reference_To (Standard_Integer, Loc)));
      end Build_S;

      -------------
      -- Build_T --
      -------------

      procedure Build_T
        (Loc    : Source_Ptr;
         Typ    : Entity_Id;
         Params : List_Id)
      is
      begin
         Append_To (Params,
           Make_Parameter_Specification (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc, Name_uT),
             Parameter_Type =>
               New_Reference_To (Typ, Loc),
             In_Present  => True,
             Out_Present => True));
      end Build_T;
   end Select_Expansion_Utilities;

   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,
       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);

   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,
       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);

   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,
       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);

   procedure Collect_All_Interfaces (T : Entity_Id);
   --  Ada 2005 (AI-251): Collect the whole list of interfaces that are
   --  directly or indirectly implemented by T. Used to compute the size
   --  of the table of interfaces.

   function Default_Prim_Op_Position (E : Entity_Id) return Uint;
   --  Ada 2005 (AI-251): Returns the fixed position in the dispatch table
   --  of the default primitive operations.

   function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
   --  Check if the type has a private view or if the public view appears
   --  in the visible part of a package spec.

   function Prim_Op_Kind
     (Prim : Entity_Id;
      Typ  : Entity_Id) return Node_Id;
   --  Ada 2005 (AI-345): Determine the primitive operation kind of Prim
   --  according to its type Typ. Return a reference to an RE_Prim_Op_Kind
   --  enumeration value.

   function Tagged_Kind (T : Entity_Id) return Node_Id;
   --  Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
   --  to an RE_Tagged_Kind enumeration value.

   ----------------------------
   -- Collect_All_Interfaces --
   ----------------------------

   procedure Collect_All_Interfaces (T : Entity_Id) is

      procedure Add_Interface (Iface : Entity_Id);
      --  Add the interface it if is not already in the list

      procedure Collect (Typ : Entity_Id);
      --  Subsidiary subprogram used to traverse the whole list
      --  of directly and indirectly implemented interfaces

      -------------------
      -- Add_Interface --
      -------------------

      procedure Add_Interface (Iface : Entity_Id) is
         Elmt : Elmt_Id;

      begin
         Elmt := First_Elmt (Abstract_Interfaces (T));
         while Present (Elmt) and then Node (Elmt) /= Iface loop
            Next_Elmt (Elmt);
         end loop;

         if No (Elmt) then
            Append_Elmt (Iface, Abstract_Interfaces (T));
         end if;
      end Add_Interface;

      -------------
      -- Collect --
      -------------

      procedure Collect (Typ : Entity_Id) is
         Ancestor : Entity_Id;
         Id       : Node_Id;
         Iface    : Entity_Id;
         Nod      : Node_Id;

      begin
         if Ekind (Typ) = E_Record_Type_With_Private then
            Nod := Type_Definition (Parent (Full_View (Typ)));
         else
            Nod := Type_Definition (Parent (Typ));
         end if;

         pragma Assert (False
            or else Nkind (Nod) = N_Derived_Type_Definition
            or else Nkind (Nod) = N_Record_Definition);

         --  Include the ancestor if we are generating the whole list
         --  of interfaces. This is used to know the size of the table
         --  that stores the tag of all the ancestor interfaces.

         Ancestor := Etype (Typ);

         if Ancestor /= Typ then
            Collect (Ancestor);
         end if;

         if Is_Interface (Ancestor) then
            Add_Interface (Ancestor);
         end if;

         --  Traverse the graph of ancestor interfaces

         if Is_Non_Empty_List (Interface_List (Nod)) then
            Id := First (Interface_List (Nod));
            while Present (Id) loop
               Iface := Etype (Id);

               if Is_Interface (Iface) then
                  Add_Interface (Iface);
                  Collect (Iface);
               end if;

               Next (Id);
            end loop;
         end if;
      end Collect;

   --  Start of processing for Collect_All_Interfaces

   begin
      Collect (T);
   end Collect_All_Interfaces;

   ------------------------------
   -- Default_Prim_Op_Position --
   ------------------------------

   function Default_Prim_Op_Position (E : Entity_Id) return Uint is
      TSS_Name : TSS_Name_Type;

   begin
      Get_Name_String (Chars (E));
      TSS_Name :=
        TSS_Name_Type
          (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));

      if Chars (E) = Name_uSize then
         return Uint_1;

      elsif Chars (E) = Name_uAlignment then
         return Uint_2;

      elsif TSS_Name = TSS_Stream_Read then
         return Uint_3;

      elsif TSS_Name = TSS_Stream_Write then
         return Uint_4;

      elsif TSS_Name = TSS_Stream_Input then
         return Uint_5;

      elsif TSS_Name = TSS_Stream_Output then
         return Uint_6;

      elsif Chars (E) = Name_Op_Eq then
         return Uint_7;

      elsif Chars (E) = Name_uAssign then
         return Uint_8;

      elsif TSS_Name = TSS_Deep_Adjust then
         return Uint_9;

      elsif TSS_Name = TSS_Deep_Finalize then
         return Uint_10;

      elsif Ada_Version >= Ada_05 then
         if Chars (E) = Name_uDisp_Asynchronous_Select then
            return Uint_11;

         elsif Chars (E) = Name_uDisp_Conditional_Select then
            return Uint_12;

         elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
            return Uint_13;

         elsif Chars (E) = Name_uDisp_Get_Task_Id then
            return Uint_14;

         elsif Chars (E) = Name_uDisp_Timed_Select then
            return Uint_15;
         end if;
      end if;

      raise Program_Error;
   end Default_Prim_Op_Position;

   -----------------------------
   -- Expand_Dispatching_Call --
   -----------------------------

   procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
      Loc      : constant Source_Ptr := Sloc (Call_Node);
      Call_Typ : constant Entity_Id  := Etype (Call_Node);

      Ctrl_Arg   : constant Node_Id := Controlling_Argument (Call_Node);
      Param_List : constant List_Id := Parameter_Associations (Call_Node);
      Subp       : Entity_Id        := Entity (Name (Call_Node));

      CW_Typ          : Entity_Id;
      New_Call        : Node_Id;
      New_Call_Name   : Node_Id;
      New_Params      : List_Id := No_List;
      Param           : Node_Id;
      Res_Typ         : Entity_Id;
      Subp_Ptr_Typ    : Entity_Id;
      Subp_Typ        : Entity_Id;
      Typ             : Entity_Id;
      Eq_Prim_Op      : Entity_Id := Empty;
      Controlling_Tag : Node_Id;

      function New_Value (From : Node_Id) return Node_Id;
      --  From is the original Expression. New_Value is equivalent to a call
      --  to Duplicate_Subexpr with an explicit dereference when From is an
      --  access parameter.

      function Controlling_Type (Subp : Entity_Id) return Entity_Id;
      --  Returns the tagged type for which Subp is a primitive subprogram

      ---------------
      -- New_Value --
      ---------------

      function New_Value (From : Node_Id) return Node_Id is
         Res : constant Node_Id := Duplicate_Subexpr (From);
      begin
         if Is_Access_Type (Etype (From)) then
            return Make_Explicit_Dereference (Sloc (From), Res);
         else
            return Res;
         end if;
      end New_Value;

      ----------------------
      -- Controlling_Type --
      ----------------------

      function Controlling_Type (Subp : Entity_Id) return Entity_Id is
      begin
         if Ekind (Subp) = E_Function
           and then Has_Controlling_Result (Subp)
         then
            return Base_Type (Etype (Subp));

         else
            declare
               Formal : Entity_Id;

            begin
               Formal := First_Formal (Subp);
               while Present (Formal) loop
                  if Is_Controlling_Formal (Formal) then
                     if Is_Access_Type (Etype (Formal)) then
                        return Base_Type (Designated_Type (Etype (Formal)));
                     else
                        return Base_Type (Etype (Formal));
                     end if;
                  end if;

                  Next_Formal (Formal);
               end loop;
            end;
         end if;

         --  Controlling type not found (should never happen)

         return Empty;
      end Controlling_Type;

   --  Start of processing for Expand_Dispatching_Call

   begin
      Check_Restriction (No_Dispatching_Calls, Call_Node);

      --  If this is an inherited operation that was overridden, the body
      --  that is being called is its alias.

      if Present (Alias (Subp))
        and then Is_Inherited_Operation (Subp)
        and then No (DTC_Entity (Subp))
      then
         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
      --  object, then use the class-wide type associated with the subprogram's
      --  controlling type. This case can occur when a call to an inherited
      --  primitive has an actual that originated from a default parameter
      --  given by a tag-indeterminate call and when there is no other
      --  controlling argument providing the tag (AI-239 requires dispatching).
      --  This capability of dispatching directly by tag is also needed by the
      --  implementation of AI-260 (for the generic dispatching constructors).

      if Etype (Ctrl_Arg) = RTE (RE_Tag)
        or else (RTE_Available (RE_Interface_Tag)
                  and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag))
      then
         CW_Typ := Class_Wide_Type (Controlling_Type (Subp));

      elsif Is_Access_Type (Etype (Ctrl_Arg)) then
         CW_Typ := Designated_Type (Etype (Ctrl_Arg));

      else
         CW_Typ := Etype (Ctrl_Arg);
      end if;

      Typ := Root_Type (CW_Typ);

      if Ekind (Typ) = E_Incomplete_Type then
         Typ := Non_Limited_View (Typ);
      end if;

      if not Is_Limited_Type (Typ) then
         Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
      end if;

      if Is_CPP_Class (Root_Type (Typ)) then

         --  Create a new parameter list with the displaced 'this'

         New_Params := New_List;
         Param := First_Actual (Call_Node);
         while Present (Param) loop
            Append_To (New_Params, Relocate_Node (Param));
            Next_Actual (Param);
         end loop;

      elsif Present (Param_List) then

         --  Generate the Tag checks when appropriate

         New_Params := New_List;
         Param := First_Actual (Call_Node);
         while Present (Param) loop

            --  No tag check with itself

            if Param = Ctrl_Arg then
               Append_To (New_Params,
                 Duplicate_Subexpr_Move_Checks (Param));

            --  No tag check for parameter whose type is neither tagged nor
            --  access to tagged (for access parameters)

            elsif No (Find_Controlling_Arg (Param)) then
               Append_To (New_Params, Relocate_Node (Param));

            --  No tag check for function dispatching on result if the
            --  Tag given by the context is this one

            elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
               Append_To (New_Params, Relocate_Node (Param));

            --  "=" is the only dispatching operation allowed to get
            --  operands with incompatible tags (it just returns false).
            --  We use Duplicate_Subexpr_Move_Checks instead of calling
            --  Relocate_Node because the value will be duplicated to
            --  check the tags.

            elsif Subp = Eq_Prim_Op then
               Append_To (New_Params,
                 Duplicate_Subexpr_Move_Checks (Param));

            --  No check in presence of suppress flags

            elsif Tag_Checks_Suppressed (Etype (Param))
              or else (Is_Access_Type (Etype (Param))
                         and then Tag_Checks_Suppressed
                                    (Designated_Type (Etype (Param))))
            then
               Append_To (New_Params, Relocate_Node (Param));

            --  Optimization: no tag checks if the parameters are identical

            elsif Is_Entity_Name (Param)
              and then Is_Entity_Name (Ctrl_Arg)
              and then Entity (Param) = Entity (Ctrl_Arg)
            then
               Append_To (New_Params, Relocate_Node (Param));

            --  Now we need to generate the Tag check

            else
               --  Generate code for tag equality check
               --  Perhaps should have Checks.Apply_Tag_Equality_Check???

               Insert_Action (Ctrl_Arg,
                 Make_Implicit_If_Statement (Call_Node,
                   Condition =>
                     Make_Op_Ne (Loc,
                       Left_Opnd =>
                         Make_Selected_Component (Loc,
                           Prefix => New_Value (Ctrl_Arg),
                           Selector_Name =>
                             New_Reference_To
                               (First_Tag_Component (Typ), Loc)),

                       Right_Opnd =>
                         Make_Selected_Component (Loc,
                           Prefix =>
                             Unchecked_Convert_To (Typ, New_Value (Param)),
                           Selector_Name =>
                             New_Reference_To
                               (First_Tag_Component (Typ), Loc))),

                   Then_Statements =>
                     New_List (New_Constraint_Error (Loc))));

               Append_To (New_Params, Relocate_Node (Param));
            end if;

            Next_Actual (Param);
         end loop;
      end if;

      --  Generate the appropriate subprogram pointer type

      if Etype (Subp) = Typ then
         Res_Typ := CW_Typ;
      else
         Res_Typ := Etype (Subp);
      end if;

      Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
      Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
      Set_Etype          (Subp_Typ, Res_Typ);
      Init_Size_Align    (Subp_Ptr_Typ);
      Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));

      --  Create a new list of parameters which is a copy of the old formal
      --  list including the creation of a new set of matching entities.

      declare
         Old_Formal : Entity_Id := First_Formal (Subp);
         New_Formal : Entity_Id;
         Extra      : Entity_Id;

      begin
         if Present (Old_Formal) then
            New_Formal := New_Copy (Old_Formal);
            Set_First_Entity (Subp_Typ, New_Formal);
            Param := First_Actual (Call_Node);

            loop
               Set_Scope (New_Formal, Subp_Typ);

               --  Change all the controlling argument types to be class-wide
               --  to avoid a recursion in dispatching.

               if Is_Controlling_Formal (New_Formal) then
                  Set_Etype (New_Formal, Etype (Param));
               end if;

               if Is_Itype (Etype (New_Formal)) then
                  Extra := New_Copy (Etype (New_Formal));

                  if Ekind (Extra) = E_Record_Subtype
                    or else Ekind (Extra) = E_Class_Wide_Subtype
                  then
                     Set_Cloned_Subtype (Extra, Etype (New_Formal));
                  end if;

                  Set_Etype (New_Formal, Extra);
                  Set_Scope (Etype (New_Formal), Subp_Typ);
               end if;

               Extra := New_Formal;
               Next_Formal (Old_Formal);
               exit when No (Old_Formal);

               Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
               Next_Entity (New_Formal);
               Next_Actual (Param);
            end loop;
            Set_Last_Entity (Subp_Typ, Extra);

            --  Copy extra formals

            New_Formal := First_Entity (Subp_Typ);
            while Present (New_Formal) loop
               if Present (Extra_Constrained (New_Formal)) then
                  Set_Extra_Formal (Extra,
                    New_Copy (Extra_Constrained (New_Formal)));
                  Extra := Extra_Formal (Extra);
                  Set_Extra_Constrained (New_Formal, Extra);

               elsif Present (Extra_Accessibility (New_Formal)) then
                  Set_Extra_Formal (Extra,
                    New_Copy (Extra_Accessibility (New_Formal)));
                  Extra := Extra_Formal (Extra);
                  Set_Extra_Accessibility (New_Formal, Extra);
               end if;

               Next_Formal (New_Formal);
            end loop;
         end if;
      end;

      Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
      Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);

      --  If the controlling argument is a value of type Ada.Tag or an abstract
      --  interface class-wide type then use it directly. Otherwise, the tag
      --  must be extracted from the controlling object.

      if Etype (Ctrl_Arg) = RTE (RE_Tag)
        or else (RTE_Available (RE_Interface_Tag)
                  and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag))
      then
         Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);

      --  Ada 2005 (AI-251): Abstract interface class-wide type

      elsif Is_Interface (Etype (Ctrl_Arg))
         and then Is_Class_Wide_Type (Etype (Ctrl_Arg))
      then
         Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);

      else
         Controlling_Tag :=
           Make_Selected_Component (Loc,
             Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
             Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
      end if;

      --  Generate:
      --   Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos));

      if Is_Predefined_Dispatching_Operation (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),

               --  Position

                 Make_Integer_Literal (Loc, DT_Position (Subp)))));

      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)))));
      end if;

      if Nkind (Call_Node) = N_Function_Call then

         --  Ada 2005 (AI-251): A dispatching "=" with an abstract interface
         --  just requires the comparison of the tags.

         if Ekind (Etype (Ctrl_Arg)) = E_Class_Wide_Type
           and then Is_Interface (Etype (Ctrl_Arg))
           and then Subp = Eq_Prim_Op
         then
            Param := First_Actual (Call_Node);

            New_Call :=
                Make_Op_Eq (Loc,
                   Left_Opnd =>
                     Make_Selected_Component (Loc,
                       Prefix => New_Value (Param),
                       Selector_Name =>
                         New_Reference_To (First_Tag_Component (Typ), Loc)),

                   Right_Opnd =>
                     Make_Selected_Component (Loc,
                       Prefix =>
                         Unchecked_Convert_To (Typ,
                           New_Value (Next_Actual (Param))),
                       Selector_Name =>
                         New_Reference_To (First_Tag_Component (Typ), Loc)));

         else
            New_Call :=
              Make_Function_Call (Loc,
                Name => New_Call_Name,
                Parameter_Associations => New_Params);

            --  If this is a dispatching "=", we must first compare the tags so
            --  we generate: x.tag = y.tag and then x = y

            if Subp = Eq_Prim_Op then
               Param := First_Actual (Call_Node);
               New_Call :=
                 Make_And_Then (Loc,
                   Left_Opnd =>
                        Make_Op_Eq (Loc,
                          Left_Opnd =>
                            Make_Selected_Component (Loc,
                              Prefix => New_Value (Param),
                              Selector_Name =>
                                New_Reference_To (First_Tag_Component (Typ),
                                                  Loc)),

                          Right_Opnd =>
                            Make_Selected_Component (Loc,
                              Prefix =>
                                Unchecked_Convert_To (Typ,
                                  New_Value (Next_Actual (Param))),
                              Selector_Name =>
                                New_Reference_To (First_Tag_Component (Typ),
                                                  Loc))),
                   Right_Opnd => New_Call);
            end if;
         end if;

      else
         New_Call :=
           Make_Procedure_Call_Statement (Loc,
             Name => New_Call_Name,
             Parameter_Associations => New_Params);
      end if;

      Rewrite (Call_Node, New_Call);
      Analyze_And_Resolve (Call_Node, Call_Typ);
   end Expand_Dispatching_Call;

   ---------------------------------
   -- Expand_Interface_Conversion --
   ---------------------------------

   procedure Expand_Interface_Conversion
     (N         : Node_Id;
      Is_Static : Boolean := True)
   is
      Loc         : constant Source_Ptr := Sloc (N);
      Operand     : constant Node_Id    := Expression (N);
      Operand_Typ : Entity_Id           := Etype (Operand);
      Iface_Typ   : Entity_Id           := Etype (N);
      Iface_Tag   : Entity_Id;
      Fent        : Entity_Id;
      Func        : Node_Id;
      P           : Node_Id;
      Null_Op_Nod : Node_Id;

   begin
      pragma Assert (Nkind (Operand) /= N_Attribute_Reference);

      --  Ada 2005 (AI-345): Handle task interfaces

      if Ekind (Operand_Typ) = E_Task_Type
        or else Ekind (Operand_Typ) = E_Protected_Type
      then
         Operand_Typ := Corresponding_Record_Type (Operand_Typ);
      end if;

      --  Handle access types to interfaces

      if Is_Access_Type (Iface_Typ) then
         Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
      end if;

      --  Handle class-wide interface types. This conversion can appear
      --  explicitly in the source code. Example: I'Class (Obj)

      if Is_Class_Wide_Type (Iface_Typ) then
         Iface_Typ := Etype (Iface_Typ);
      end if;

      pragma Assert (not Is_Class_Wide_Type (Iface_Typ)
        and then Is_Interface (Iface_Typ));

      if not Is_Static then

         --  Give error if configurable run time and Displace not available

         if not RTE_Available (RE_Displace) then
            Error_Msg_CRT ("abstract interface types", N);
            return;
         end if;

         Rewrite (N,
           Make_Function_Call (Loc,
             Name => New_Reference_To (RTE (RE_Displace), Loc),
             Parameter_Associations => New_List (
               Make_Attribute_Reference (Loc,
                 Prefix => Relocate_Node (Expression (N)),
                 Attribute_Name => Name_Address),
               New_Occurrence_Of
                 (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
                  Loc))));

         Analyze (N);

         --  Change the type of the data returned by IW_Convert to
         --  indicate that this is a dispatching call.

         declare
            New_Itype : Entity_Id;

         begin
            New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
            Set_Etype       (New_Itype, New_Itype);
            Init_Size_Align (New_Itype);
            Set_Directly_Designated_Type (New_Itype,
              Class_Wide_Type (Iface_Typ));

            Rewrite (N, Make_Explicit_Dereference (Loc,
                          Unchecked_Convert_To (New_Itype,
                            Relocate_Node (N))));
            Analyze (N);
         end;

         return;
      end if;

      Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
      pragma Assert (Iface_Tag /= Empty);

      --  Keep separate access types to interfaces because one internal
      --  function is used to handle the null value (see following comment)

      if not Is_Access_Type (Etype (N)) then
         Rewrite (N,
           Unchecked_Convert_To (Etype (N),
             Make_Selected_Component (Loc,
               Prefix => Relocate_Node (Expression (N)),
               Selector_Name =>
                 New_Occurrence_Of (Iface_Tag, Loc))));

      else
         --  Build internal function to handle the case in which the
         --  actual is null. If the actual is null returns null because
         --  no displacement is required; otherwise performs a type
         --  conversion that will be expanded in the code that returns
         --  the value of the displaced actual. That is:

         --     function Func (O : Operand_Typ) return Iface_Typ is
         --     begin
         --        if O = null then
         --           return null;
         --        else
         --           return Iface_Typ!(O);
         --        end if;
         --     end Func;

         Fent :=
           Make_Defining_Identifier (Loc, New_Internal_Name ('F'));

         --  Decorate the "null" in the if-statement condition

         Null_Op_Nod := Make_Null (Loc);
         Set_Etype (Null_Op_Nod, Etype (Operand));
         Set_Analyzed (Null_Op_Nod);

         Func :=
           Make_Subprogram_Body (Loc,
             Specification =>
               Make_Function_Specification (Loc,
                 Defining_Unit_Name       => Fent,

                 Parameter_Specifications => New_List (
                   Make_Parameter_Specification (Loc,
                     Defining_Identifier =>
                       Make_Defining_Identifier (Loc, Name_uO),
                     Parameter_Type =>
                       New_Reference_To (Etype (Operand), Loc))),
                 Result_Definition =>
                   New_Reference_To (Etype (N), Loc)),

             Declarations => Empty_List,

             Handled_Statement_Sequence =>
               Make_Handled_Sequence_Of_Statements (Loc,
                 Statements => New_List (
                   Make_If_Statement (Loc,
                     Condition       =>
                       Make_Op_Eq (Loc,
                          Left_Opnd  => Make_Identifier (Loc, Name_uO),
                          Right_Opnd => Null_Op_Nod),
                     Then_Statements => New_List (
                       Make_Return_Statement (Loc,
                         Make_Null (Loc))),
                     Else_Statements => New_List (
                       Make_Return_Statement (Loc,
                         Unchecked_Convert_To (Etype (N),
                            Make_Attribute_Reference (Loc,
                              Prefix =>
                                Make_Selected_Component (Loc,
                                  Prefix => Make_Identifier (Loc, Name_uO),
                                  Selector_Name =>
                                    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;

         Analyze (Func);

         Rewrite (N,
           Make_Function_Call (Loc,
             Name => New_Reference_To (Fent, Loc),
             Parameter_Associations => New_List (
               Relocate_Node (Expression (N)))));
      end if;

      Analyze (N);
   end Expand_Interface_Conversion;

   ------------------------------
   -- Expand_Interface_Actuals --
   ------------------------------

   procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
      Loc        : constant Source_Ptr := Sloc (Call_Node);
      Actual     : Node_Id;
      Actual_Dup : Node_Id;
      Actual_Typ : Entity_Id;
      Anon       : Entity_Id;
      Conversion : Node_Id;
      Formal     : Entity_Id;
      Formal_Typ : Entity_Id;
      Subp       : Entity_Id;
      Nam        : Name_Id;
      Formal_DDT : Entity_Id;
      Actual_DDT : Entity_Id;

   begin
      --  This subprogram 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;

      --  Call using access to subprogram with explicit dereference

      if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
         Subp := Etype (Name (Call_Node));

      --  Normal case

      else
         Subp := Entity (Name (Call_Node));
      end if;

      Formal := First_Formal (Subp);
      Actual := First_Actual (Call_Node);
      while Present (Formal) loop

         --  Ada 2005 (AI-251): Conversion to interface to force "this"
         --  displacement.

         Formal_Typ := Etype (Etype (Formal));

         if Ekind (Formal_Typ) = E_Record_Type_With_Private then
            Formal_Typ := Full_View (Formal_Typ);
         end if;

         if Is_Access_Type (Formal_Typ) then
            Formal_DDT := Directly_Designated_Type (Formal_Typ);
         end if;

         Actual_Typ := Etype (Actual);

         if Is_Access_Type (Actual_Typ) then
            Actual_DDT := Directly_Designated_Type (Actual_Typ);
         end if;

         if Is_Interface (Formal_Typ) then

            --  No need to displace the pointer if the type of the actual
            --  is class-wide of the formal-type interface; in this case the
            --  displacement of the pointer was already done at the point of
            --  the call to the enclosing subprogram. This case corresponds
            --  with the call to P (Obj) in the following example:

            --     type I is interface;
            --     procedure P (X : I) is abstract;

            --     procedure General_Op (Obj : I'Class) is
            --     begin
            --        P (Obj);
            --     end General_Op;

            if Is_Class_Wide_Type (Actual_Typ)
              and then Etype (Actual_Typ) = Formal_Typ
            then
               null;

            --  No need to displace the pointer if the type of the actual is a
            --  derivation of the formal-type interface because in this case
            --  the interface primitives are located in the primary dispatch
            --  table.

            elsif Is_Ancestor (Formal_Typ, Actual_Typ) then
               null;

            else
               Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
               Rewrite             (Actual, Conversion);
               Analyze_And_Resolve (Actual, Formal_Typ);
            end if;

         --  Anonymous access type

         elsif Is_Access_Type (Formal_Typ)
           and then Is_Interface (Etype (Formal_DDT))
           and then Interface_Present_In_Ancestor
                      (Typ   => Actual_DDT,
                       Iface => Etype (Formal_DDT))
         then
            if Nkind (Actual) = N_Attribute_Reference
              and then
               (Attribute_Name (Actual) = Name_Access
                 or else Attribute_Name (Actual) = Name_Unchecked_Access)
            then
               Nam := Attribute_Name (Actual);

               Conversion := Convert_To (Etype (Formal_DDT), Prefix (Actual));

               Rewrite (Actual, Conversion);
               Analyze_And_Resolve (Actual, Etype (Formal_DDT));

               Rewrite (Actual,
                 Unchecked_Convert_To (Formal_Typ,
                   Make_Attribute_Reference (Loc,
                     Prefix => Relocate_Node (Actual),
                     Attribute_Name => Nam)));

               Analyze_And_Resolve (Actual, Formal_Typ);

            --  No need to displace the pointer if the actual is a class-wide
            --  type of the formal-type interface because in this case the
            --  displacement of the pointer was already done at the point of
            --  the call to the enclosing subprogram (this case is similar
            --  to the example described above for the non access-type case)

            elsif Is_Class_Wide_Type (Actual_DDT)
              and then Etype (Actual_DDT) = Formal_DDT
            then
               null;

            --  No need to displace the pointer if the type of the actual is a
            --  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
               null;

            else
               Actual_Dup := Relocate_Node (Actual);

               if From_With_Type (Actual_Typ) then

                  --  If the type of the actual parameter comes from a limited
                  --  with-clause and the non-limited view is already available
                  --  we replace the anonymous access type by a duplicate decla
                  --  ration whose designated type is the non-limited view

                  if Ekind (Actual_DDT) = E_Incomplete_Type
                    and then Present (Non_Limited_View (Actual_DDT))
                  then
                     Anon := New_Copy (Actual_Typ);

                     if Is_Itype (Anon) then
                        Set_Scope (Anon, Current_Scope);
                     end if;

                     Set_Directly_Designated_Type (Anon,
                       Non_Limited_View (Actual_DDT));
                     Set_Etype (Actual_Dup, Anon);

                  elsif Is_Class_Wide_Type (Actual_DDT)
                    and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type
                    and then Present (Non_Limited_View (Etype (Actual_DDT)))
                  then
                     Anon := New_Copy (Actual_Typ);

                     if Is_Itype (Anon) then
                        Set_Scope (Anon, Current_Scope);
                     end if;

                     Set_Directly_Designated_Type (Anon,
                       New_Copy (Actual_DDT));
                     Set_Class_Wide_Type (Directly_Designated_Type (Anon),
                       New_Copy (Class_Wide_Type (Actual_DDT)));
                     Set_Etype (Directly_Designated_Type (Anon),
                       Non_Limited_View (Etype (Actual_DDT)));
                     Set_Etype (
                       Class_Wide_Type (Directly_Designated_Type (Anon)),
                       Non_Limited_View (Etype (Actual_DDT)));
                     Set_Etype (Actual_Dup, Anon);
                  end if;
               end if;

               Conversion := Convert_To (Formal_Typ, Actual_Dup);
               Rewrite (Actual, Conversion);
               Analyze_And_Resolve (Actual, Formal_Typ);
            end if;
         end if;

         Next_Actual (Actual);
         Next_Formal (Formal);
      end loop;
   end Expand_Interface_Actuals;

   ----------------------------
   -- Expand_Interface_Thunk --
   ----------------------------

   function Expand_Interface_Thunk
     (N           : Node_Id;
      Thunk_Alias : Entity_Id;
      Thunk_Id    : Entity_Id) return Node_Id
   is
      Loc         : constant Source_Ptr := Sloc (N);
      Actuals     : constant List_Id    := New_List;
      Decl        : constant List_Id    := New_List;
      Formals     : constant List_Id    := New_List;
      Target      : Entity_Id;
      New_Code    : Node_Id;
      Formal      : Node_Id;
      New_Formal  : Node_Id;
      Decl_1      : Node_Id;
      Decl_2      : Node_Id;
      E           : Entity_Id;

   begin
      --  Traverse the list of alias to find the final target

      Target := Thunk_Alias;
      while Present (Alias (Target)) loop
         Target := Alias (Target);
      end loop;

      --  Duplicate the formals

      Formal := First_Formal (Target);
      E      := First_Formal (N);
      while Present (Formal) loop
         New_Formal := Copy_Separate_Tree (Parent (Formal));

         --  Propagate the parameter type to the copy. This is required to
         --  properly handle the case in which the subprogram covering the
         --  interface has been inherited:

         --  Example:
         --     type I is interface;
         --     procedure P (X : in I) is abstract;

         --     type T is tagged null record;
         --     procedure P (X : T);

         --     type DT is new T and I with ...

         Set_Parameter_Type (New_Formal, New_Reference_To (Etype (E), Loc));
         Append_To (Formals, New_Formal);

         Next_Formal (Formal);
         Next_Formal (E);
      end loop;

      --  Give message if configurable run-time and Offset_To_Top unavailable

      if not RTE_Available (RE_Offset_To_Top) then
         Error_Msg_CRT ("abstract interface types", N);
         return Empty;
      end if;

      if Ekind (First_Formal (Target)) = E_In_Parameter
        and then Ekind (Etype (First_Formal (Target)))
                  = E_Anonymous_Access_Type
      then
         --  Generate:

         --     type T is access all <<type of the first formal>>
         --     S1 := Storage_Offset!(First_formal)
         --           - Offset_To_Top (First_Formal.Tag)

         --  ... and the first actual of the call is generated as T!(S1)

         Decl_2 :=
           Make_Full_Type_Declaration (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc,
                 New_Internal_Name ('T')),
             Type_Definition =>
               Make_Access_To_Object_Definition (Loc,
                 All_Present            => True,
                 Null_Exclusion_Present => False,
                 Constant_Present       => False,
                 Subtype_Indication     =>
                   New_Reference_To
                     (Directly_Designated_Type
                        (Etype (First_Formal (Target))), Loc)));

         Decl_1 :=
           Make_Object_Declaration (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc,
                 New_Internal_Name ('S')),
             Constant_Present    => True,
             Object_Definition   =>
               New_Reference_To (RTE (RE_Storage_Offset), Loc),
             Expression          =>
               Make_Op_Subtract (Loc,
                 Left_Opnd  =>
                   Unchecked_Convert_To
                     (RTE (RE_Storage_Offset),
                      New_Reference_To
                        (Defining_Identifier (First (Formals)), Loc)),
                  Right_Opnd =>
                    Make_Function_Call (Loc,
                      Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
                      Parameter_Associations => New_List (
                        Unchecked_Convert_To
                          (RTE (RE_Address),
                           New_Reference_To
                             (Defining_Identifier (First (Formals)), Loc))))));

         Append_To (Decl, Decl_2);
         Append_To (Decl, Decl_1);

         --  Reference the new first actual

         Append_To (Actuals,
           Unchecked_Convert_To
             (Defining_Identifier (Decl_2),
              New_Reference_To (Defining_Identifier (Decl_1), Loc)));

      else
         --  Generate:

         --     S1 := Storage_Offset!(First_formal'Address)
         --           - Offset_To_Top (First_Formal.Tag)
         --     S2 := Tag_Ptr!(S3)

         Decl_1 :=
           Make_Object_Declaration (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
             Constant_Present    => True,
             Object_Definition   =>
               New_Reference_To (RTE (RE_Storage_Offset), Loc),
             Expression          =>
               Make_Op_Subtract (Loc,
                 Left_Opnd =>
                   Unchecked_Convert_To
                     (RTE (RE_Storage_Offset),
                      Make_Attribute_Reference (Loc,
                        Prefix =>
                          New_Reference_To
                            (Defining_Identifier (First (Formals)), Loc),
                        Attribute_Name => Name_Address)),
                 Right_Opnd =>
                    Make_Function_Call (Loc,
                      Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
                      Parameter_Associations => New_List (
                        Make_Attribute_Reference (Loc,
                          Prefix => New_Reference_To
                                      (Defining_Identifier (First (Formals)),
                                       Loc),
                          Attribute_Name => Name_Address)))));

         Decl_2 :=
           Make_Object_Declaration (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
             Constant_Present    => True,
             Object_Definition   => New_Reference_To (RTE (RE_Addr_Ptr), Loc),
             Expression          =>
               Unchecked_Convert_To
                 (RTE (RE_Addr_Ptr),
                  New_Reference_To (Defining_Identifier (Decl_1), Loc)));

         Append_To (Decl, Decl_1);
         Append_To (Decl, Decl_2);

         --  Reference the new first actual

         Append_To (Actuals,
           Unchecked_Convert_To
             (Etype (First_Entity (Target)),
              Make_Explicit_Dereference (Loc,
                New_Reference_To (Defining_Identifier (Decl_2), Loc))));
      end if;

      Formal := Next (First (Formals));
      while Present (Formal) loop
         Append_To (Actuals,
            New_Reference_To (Defining_Identifier (Formal), Loc));
         Next (Formal);
      end loop;

      if Ekind (Target) = E_Procedure then
         New_Code :=
           Make_Subprogram_Body (Loc,
              Specification =>
                Make_Procedure_Specification (Loc,
                  Defining_Unit_Name       => Thunk_Id,
                  Parameter_Specifications => Formals),
              Declarations => Decl,
              Handled_Statement_Sequence =>
                Make_Handled_Sequence_Of_Statements (Loc,
                  Statements => New_List (
                    Make_Procedure_Call_Statement (Loc,
                       Name => New_Occurrence_Of (Target, Loc),
                       Parameter_Associations => Actuals))));

      else pragma Assert (Ekind (Target) = E_Function);

         New_Code :=
           Make_Subprogram_Body (Loc,
              Specification =>
                Make_Function_Specification (Loc,
                  Defining_Unit_Name       => Thunk_Id,
                  Parameter_Specifications => Formals,
                  Result_Definition =>
                    New_Copy (Result_Definition (Parent (Target)))),
              Declarations => Decl,
              Handled_Statement_Sequence =>
                Make_Handled_Sequence_Of_Statements (Loc,
                  Statements => New_List (
                    Make_Return_Statement (Loc,
                      Make_Function_Call (Loc,
                        Name => New_Occurrence_Of (Target, Loc),
                        Parameter_Associations => Actuals)))));
      end if;

      Analyze (New_Code);
      return New_Code;
   end Expand_Interface_Thunk;

   -------------------
   -- Fill_DT_Entry --
   -------------------

   function Fill_DT_Entry
     (Loc     : Source_Ptr;
      Prim    : Entity_Id) return Node_Id
   is
      Typ     : constant Entity_Id := Scope (DTC_Entity (Prim));
      DT_Ptr  : constant Entity_Id :=
                  Node (First_Elmt (Access_Disp_Table (Typ)));
      Pos     : constant Uint      := DT_Position (Prim);
      Tag     : constant Entity_Id := First_Tag_Component (Typ);

   begin
      pragma Assert (not Restriction_Active (No_Dispatching_Calls));

      if Is_Predefined_Dispatching_Operation (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

               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)));
      end if;
   end Fill_DT_Entry;

   -----------------------------
   -- Fill_Secondary_DT_Entry --
   -----------------------------

   function Fill_Secondary_DT_Entry
     (Loc          : Source_Ptr;
      Prim         : Entity_Id;
      Thunk_Id     : Entity_Id;
      Iface_DT_Ptr : Entity_Id) return Node_Id
   is
      Typ        : constant Entity_Id := Scope (DTC_Entity (Alias (Prim)));
      Iface_Prim : constant Entity_Id := Abstract_Interface_Alias (Prim);
      Pos        : constant Uint      := DT_Position (Iface_Prim);
      Tag        : constant Entity_Id :=
                     First_Tag_Component (Scope (DTC_Entity (Iface_Prim)));

   begin
      if Is_Predefined_Dispatching_Operation (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
                 Prefix          => New_Reference_To (Thunk_Id, 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 (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)));
      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;

   ----------------------------------------
   -- Make_Disp_Asynchronous_Select_Body --
   ----------------------------------------

   function Make_Disp_Asynchronous_Select_Body
     (Typ : Entity_Id) return Node_Id
   is
      Conc_Typ : Entity_Id           := Empty;
      Decls    : constant List_Id    := New_List;
      DT_Ptr   : Entity_Id;
      Loc      : constant Source_Ptr := Sloc (Typ);
      Stmts    : constant List_Id    := New_List;

   begin
      pragma Assert (not Restriction_Active (No_Dispatching_Calls));

      --  Null body is generated for interface types

      if Is_Interface (Typ) then
         return
           Make_Subprogram_Body (Loc,
             Specification =>
               Make_Disp_Asynchronous_Select_Spec (Typ),
             Declarations =>
               New_List,
             Handled_Statement_Sequence =>
               Make_Handled_Sequence_Of_Statements (Loc,
                 New_List (Make_Null_Statement (Loc))));
      end if;

      DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));

      if Is_Concurrent_Record_Type (Typ) then
         Conc_Typ := Corresponding_Concurrent_Type (Typ);

         --  Generate:
         --    I : Integer := Get_Entry_Index (tag! (<type>VP), S);

         --  where I will be used to capture the entry index of the primitive
         --  wrapper at position S.

         Append_To (Decls,
           Make_Object_Declaration (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc, Name_uI),
             Object_Definition =>
               New_Reference_To (Standard_Integer, Loc),
             Expression =>
               Make_DT_Access_Action (Typ,
                 Action =>
                   Get_Entry_Index,
                 Args =>
                   New_List (
                     Unchecked_Convert_To (RTE (RE_Tag),
                       New_Reference_To (DT_Ptr, Loc)),
                     Make_Identifier (Loc, Name_uS)))));

         if Ekind (Conc_Typ) = E_Protected_Type then

            --  Generate:
            --    Protected_Entry_Call (
            --      T._object'access,
            --      protected_entry_index! (I),
            --      P,
            --      Asynchronous_Call,
            --      B);

            --  where T is the protected object, I is the entry index, P are
            --  the wrapped parameters and B is the name of the communication
            --  block.

            Append_To (Stmts,
              Make_Procedure_Call_Statement (Loc,
                Name =>
                  New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
                Parameter_Associations =>
                  New_List (

                    Make_Attribute_Reference (Loc,        -- T._object'access
                      Attribute_Name =>
                        Name_Unchecked_Access,
                      Prefix =>
                        Make_Selected_Component (Loc,
                          Prefix =>
                            Make_Identifier (Loc, Name_uT),
                          Selector_Name =>
                            Make_Identifier (Loc, Name_uObject))),

                    Make_Unchecked_Type_Conversion (Loc,  --  entry index
                      Subtype_Mark =>
                        New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
                      Expression =>
                        Make_Identifier (Loc, Name_uI)),

                    Make_Identifier (Loc, Name_uP),       --  parameter block
                    New_Reference_To (                    --  Asynchronous_Call
                      RTE (RE_Asynchronous_Call), Loc),
                    Make_Identifier (Loc, Name_uB))));    --  comm block
         else
            pragma Assert (Ekind (Conc_Typ) = E_Task_Type);

            --  Generate:
            --    Protected_Entry_Call (
            --      T._task_id,
            --      task_entry_index! (I),
            --      P,
            --      Conditional_Call,
            --      F);

            --  where T is the task object, I is the entry index, P are the
            --  wrapped parameters and F is the status flag.

            Append_To (Stmts,
              Make_Procedure_Call_Statement (Loc,
                Name =>
                  New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
                Parameter_Associations =>
                  New_List (

                    Make_Selected_Component (Loc,         -- T._task_id
                      Prefix =>
                        Make_Identifier (Loc, Name_uT),
                      Selector_Name =>
                        Make_Identifier (Loc, Name_uTask_Id)),

                    Make_Unchecked_Type_Conversion (Loc,  --  entry index
                      Subtype_Mark =>
                        New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
                      Expression =>
                        Make_Identifier (Loc, Name_uI)),

                    Make_Identifier (Loc, Name_uP),       --  parameter block
                    New_Reference_To (                    --  Asynchronous_Call
                      RTE (RE_Asynchronous_Call), Loc),
                    Make_Identifier (Loc, Name_uF))));    --  status flag
         end if;
      end if;

      return
        Make_Subprogram_Body (Loc,
          Specification =>
            Make_Disp_Asynchronous_Select_Spec (Typ),
          Declarations =>
            Decls,
          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc, Stmts));
   end Make_Disp_Asynchronous_Select_Body;

   ----------------------------------------
   -- Make_Disp_Asynchronous_Select_Spec --
   ----------------------------------------

   function Make_Disp_Asynchronous_Select_Spec
     (Typ : Entity_Id) return Node_Id
   is
      Loc    : constant Source_Ptr := Sloc (Typ);
      Def_Id : constant Node_Id    :=
                 Make_Defining_Identifier (Loc,
                   Name_uDisp_Asynchronous_Select);
      Params : constant List_Id    := New_List;

   begin
      pragma Assert (not Restriction_Active (No_Dispatching_Calls));

      --  "T" - Object parameter
      --  "S" - Primitive operation slot
      --  "P" - Wrapped parameters
      --  "B" - Communication block
      --  "F" - Status flag

      SEU.Build_T (Loc, Typ, Params);
      SEU.Build_S (Loc, Params);
      SEU.Build_P (Loc, Params);
      SEU.Build_B (Loc, Params);
      SEU.Build_F (Loc, Params);

      Set_Is_Internal (Def_Id);

      return
         Make_Procedure_Specification (Loc,
           Defining_Unit_Name       => Def_Id,
           Parameter_Specifications => Params);
   end Make_Disp_Asynchronous_Select_Spec;

   ---------------------------------------
   -- Make_Disp_Conditional_Select_Body --
   ---------------------------------------

   function Make_Disp_Conditional_Select_Body
     (Typ : Entity_Id) return Node_Id
   is
      Loc      : constant Source_Ptr := Sloc (Typ);
      Blk_Nam  : Entity_Id;
      Conc_Typ : Entity_Id           := Empty;
      Decls    : constant List_Id    := New_List;
      DT_Ptr   : Entity_Id;
      Stmts    : constant List_Id    := New_List;

   begin
      pragma Assert (not Restriction_Active (No_Dispatching_Calls));

      --  Null body is generated for interface types

      if Is_Interface (Typ) then
         return
           Make_Subprogram_Body (Loc,
             Specification =>
               Make_Disp_Conditional_Select_Spec (Typ),
             Declarations =>
               No_List,
             Handled_Statement_Sequence =>
               Make_Handled_Sequence_Of_Statements (Loc,
                 New_List (Make_Null_Statement (Loc))));
      end if;

      DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));

      if Is_Concurrent_Record_Type (Typ) then
         Conc_Typ := Corresponding_Concurrent_Type (Typ);

         --  Generate:
         --    I : Integer;

         --  where I will be used to capture the entry index of the primitive
         --  wrapper at position S.

         Append_To (Decls,
           Make_Object_Declaration (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc, Name_uI),
             Object_Definition =>
               New_Reference_To (Standard_Integer, Loc)));

         --  Generate:
         --    C := Get_Prim_Op_Kind (tag! (<type>VP), S);

         --    if C = POK_Procedure
         --      or else C = POK_Protected_Procedure
         --      or else C = POK_Task_Procedure;
         --    then
         --       F := True;
         --       return;
         --    end if;

         SEU.Build_Common_Dispatching_Select_Statements
          (Loc, Typ, DT_Ptr, Stmts);

         --  Generate:
         --    Bnn : Communication_Block;

         --  where Bnn is the name of the communication block used in
         --  the call to Protected_Entry_Call.

         Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));

         Append_To (Decls,
           Make_Object_Declaration (Loc,
             Defining_Identifier =>
               Blk_Nam,
             Object_Definition =>
               New_Reference_To (RTE (RE_Communication_Block), Loc)));

         --  Generate:
         --    I := Get_Entry_Index (tag! (<type>VP), S);

         --  I is the entry index and S is the dispatch table slot

         Append_To (Stmts,
           Make_Assignment_Statement (Loc,
             Name =>
               Make_Identifier (Loc, Name_uI),
             Expression =>
               Make_DT_Access_Action (Typ,
                 Action =>
                   Get_Entry_Index,
                 Args =>
                   New_List (
                     Unchecked_Convert_To (RTE (RE_Tag),
                       New_Reference_To (DT_Ptr, Loc)),
                     Make_Identifier (Loc, Name_uS)))));

         if Ekind (Conc_Typ) = E_Protected_Type then

            --  Generate:
            --    Protected_Entry_Call (
            --      T._object'access,
            --      protected_entry_index! (I),
            --      P,
            --      Conditional_Call,
            --      Bnn);

            --  where T is the protected object, I is the entry index, P are
            --  the wrapped parameters and Bnn is the name of the communication
            --  block.

            Append_To (Stmts,
              Make_Procedure_Call_Statement (Loc,
                Name =>
                  New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
                Parameter_Associations =>
                  New_List (

                    Make_Attribute_Reference (Loc,        -- T._object'access
                      Attribute_Name =>
                        Name_Unchecked_Access,
                      Prefix =>
                        Make_Selected_Component (Loc,
                          Prefix =>
                            Make_Identifier (Loc, Name_uT),
                          Selector_Name =>
                            Make_Identifier (Loc, Name_uObject))),

                    Make_Unchecked_Type_Conversion (Loc,  --  entry index
                      Subtype_Mark =>
                        New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
                      Expression =>
                        Make_Identifier (Loc, Name_uI)),

                    Make_Identifier (Loc, Name_uP),       --  parameter block
                    New_Reference_To (                    --  Conditional_Call
                      RTE (RE_Conditional_Call), Loc),
                    New_Reference_To (                    --  Bnn
                      Blk_Nam, Loc))));

            --  Generate:
            --    F := not Cancelled (Bnn);

            --  where F is the success flag. The status of Cancelled is negated
            --  in order to match the behaviour of the version for task types.

            Append_To (Stmts,
              Make_Assignment_Statement (Loc,
                Name =>
                  Make_Identifier (Loc, Name_uF),
                Expression =>
                  Make_Op_Not (Loc,
                    Right_Opnd =>
                      Make_Function_Call (Loc,
                        Name =>
                          New_Reference_To (RTE (RE_Cancelled), Loc),
                        Parameter_Associations =>
                          New_List (
                            New_Reference_To (Blk_Nam, Loc))))));
         else
            pragma Assert (Ekind (Conc_Typ) = E_Task_Type);

            --  Generate:
            --    Protected_Entry_Call (
            --      T._task_id,
            --      task_entry_index! (I),
            --      P,
            --      Conditional_Call,
            --      F);

            --  where T is the task object, I is the entry index, P are the
            --  wrapped parameters and F is the status flag.

            Append_To (Stmts,
              Make_Procedure_Call_Statement (Loc,
                Name =>
                  New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
                Parameter_Associations =>
                  New_List (

                    Make_Selected_Component (Loc,         -- T._task_id
                      Prefix =>
                        Make_Identifier (Loc, Name_uT),
                      Selector_Name =>
                        Make_Identifier (Loc, Name_uTask_Id)),

                    Make_Unchecked_Type_Conversion (Loc,  --  entry index
                      Subtype_Mark =>
                        New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
                      Expression =>
                        Make_Identifier (Loc, Name_uI)),

                    Make_Identifier (Loc, Name_uP),       --  parameter block
                    New_Reference_To (                    --  Conditional_Call
                      RTE (RE_Conditional_Call), Loc),
                    Make_Identifier (Loc, Name_uF))));    --  status flag
         end if;
      end if;

      return
        Make_Subprogram_Body (Loc,
          Specification =>
            Make_Disp_Conditional_Select_Spec (Typ),
          Declarations =>
            Decls,
          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc, Stmts));
   end Make_Disp_Conditional_Select_Body;

   ---------------------------------------
   -- Make_Disp_Conditional_Select_Spec --
   ---------------------------------------

   function Make_Disp_Conditional_Select_Spec
     (Typ : Entity_Id) return Node_Id
   is
      Loc    : constant Source_Ptr := Sloc (Typ);
      Def_Id : constant Node_Id    :=
                 Make_Defining_Identifier (Loc,
                   Name_uDisp_Conditional_Select);
      Params : constant List_Id    := New_List;

   begin
      pragma Assert (not Restriction_Active (No_Dispatching_Calls));

      --  "T" - Object parameter
      --  "S" - Primitive operation slot
      --  "P" - Wrapped parameters
      --  "C" - Call kind
      --  "F" - Status flag

      SEU.Build_T (Loc, Typ, Params);
      SEU.Build_S (Loc, Params);
      SEU.Build_P (Loc, Params);
      SEU.Build_C (Loc, Params);
      SEU.Build_F (Loc, Params);

      Set_Is_Internal (Def_Id);

      return
        Make_Procedure_Specification (Loc,
          Defining_Unit_Name       => Def_Id,
          Parameter_Specifications => Params);
   end Make_Disp_Conditional_Select_Spec;

   -------------------------------------
   -- Make_Disp_Get_Prim_Op_Kind_Body --
   -------------------------------------

   function Make_Disp_Get_Prim_Op_Kind_Body
     (Typ : Entity_Id) return Node_Id
   is
      Loc    : constant Source_Ptr := Sloc (Typ);
      DT_Ptr : Entity_Id;

   begin
      pragma Assert (not Restriction_Active (No_Dispatching_Calls));

      if Is_Interface (Typ) then
         return
           Make_Subprogram_Body (Loc,
             Specification =>
               Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
             Declarations =>
               New_List,
             Handled_Statement_Sequence =>
               Make_Handled_Sequence_Of_Statements (Loc,
                 New_List (Make_Null_Statement (Loc))));
      end if;

      DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));

      --  Generate:
      --    C := get_prim_op_kind (tag! (<type>VP), S);

      --  where C is the out parameter capturing the call kind and S is the
      --  dispatch table slot number.

      return
        Make_Subprogram_Body (Loc,
          Specification =>
            Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
          Declarations =>
            New_List,
          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc,
              New_List (
                Make_Assignment_Statement (Loc,
                  Name =>
                    Make_Identifier (Loc, Name_uC),
                  Expression =>
                    Make_DT_Access_Action (Typ,
                      Action =>
                        Get_Prim_Op_Kind,
                      Args =>
                        New_List (
                          Unchecked_Convert_To (RTE (RE_Tag),
                            New_Reference_To (DT_Ptr, Loc)),
                            Make_Identifier (Loc, Name_uS)))))));
   end Make_Disp_Get_Prim_Op_Kind_Body;

   -------------------------------------
   -- Make_Disp_Get_Prim_Op_Kind_Spec --
   -------------------------------------

   function Make_Disp_Get_Prim_Op_Kind_Spec
     (Typ : Entity_Id) return Node_Id
   is
      Loc    : constant Source_Ptr := Sloc (Typ);
      Def_Id : constant Node_Id    :=
                 Make_Defining_Identifier (Loc,
                   Name_uDisp_Get_Prim_Op_Kind);
      Params : constant List_Id    := New_List;

   begin
      pragma Assert (not Restriction_Active (No_Dispatching_Calls));

      --  "T" - Object parameter
      --  "S" - Primitive operation slot
      --  "C" - Call kind

      SEU.Build_T (Loc, Typ, Params);
      SEU.Build_S (Loc, Params);
      SEU.Build_C (Loc, Params);

      Set_Is_Internal (Def_Id);

      return
        Make_Procedure_Specification (Loc,
           Defining_Unit_Name       => Def_Id,
           Parameter_Specifications => Params);
   end Make_Disp_Get_Prim_Op_Kind_Spec;

   --------------------------------
   -- Make_Disp_Get_Task_Id_Body --
   --------------------------------

   function Make_Disp_Get_Task_Id_Body
     (Typ : Entity_Id) return Node_Id
   is
      Loc : constant Source_Ptr := Sloc (Typ);
      Ret : Node_Id;

   begin
      pragma Assert (not Restriction_Active (No_Dispatching_Calls));

      if Is_Concurrent_Record_Type (Typ)
        and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
      then
         Ret :=
           Make_Return_Statement (Loc,
             Expression =>
               Make_Selected_Component (Loc,
                 Prefix =>
                   Make_Identifier (Loc, Name_uT),
                 Selector_Name =>
                   Make_Identifier (Loc, Name_uTask_Id)));

      --  A null body is constructed for non-task types

      else
         Ret :=
           Make_Return_Statement (Loc,
             Expression =>
               New_Reference_To (RTE (RO_ST_Null_Task), Loc));
      end if;

      return
        Make_Subprogram_Body (Loc,
          Specification =>
            Make_Disp_Get_Task_Id_Spec (Typ),
          Declarations =>
            New_List,
          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc,
              New_List (Ret)));
   end Make_Disp_Get_Task_Id_Body;

   --------------------------------
   -- Make_Disp_Get_Task_Id_Spec --
   --------------------------------

   function Make_Disp_Get_Task_Id_Spec
     (Typ : Entity_Id) return Node_Id
   is
      Loc    : constant Source_Ptr := Sloc (Typ);
      Def_Id : constant Node_Id    :=
                 Make_Defining_Identifier (Loc,
                   Name_uDisp_Get_Task_Id);

   begin
      pragma Assert (not Restriction_Active (No_Dispatching_Calls));

      Set_Is_Internal (Def_Id);

      return
        Make_Function_Specification (Loc,
          Defining_Unit_Name       => Def_Id,
          Parameter_Specifications => New_List (
            Make_Parameter_Specification (Loc,
              Defining_Identifier =>
                Make_Defining_Identifier (Loc, Name_uT),
              Parameter_Type =>
                New_Reference_To (Typ, Loc))),
          Result_Definition =>
            New_Reference_To (RTE (RO_ST_Task_Id), Loc));
   end Make_Disp_Get_Task_Id_Spec;

   ---------------------------------
   -- Make_Disp_Timed_Select_Body --
   ---------------------------------

   function Make_Disp_Timed_Select_Body
     (Typ : Entity_Id) return Node_Id
   is
      Loc      : constant Source_Ptr := Sloc (Typ);
      Conc_Typ : Entity_Id           := Empty;
      Decls    : constant List_Id    := New_List;
      DT_Ptr   : Entity_Id;
      Stmts    : constant List_Id    := New_List;

   begin
      pragma Assert (not Restriction_Active (No_Dispatching_Calls));

      --  Null body is generated for interface types

      if Is_Interface (Typ) then
         return
           Make_Subprogram_Body (Loc,
             Specification =>
               Make_Disp_Timed_Select_Spec (Typ),
             Declarations =>
               New_List,
             Handled_Statement_Sequence =>
               Make_Handled_Sequence_Of_Statements (Loc,
                 New_List (Make_Null_Statement (Loc))));
      end if;

      DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));

      if Is_Concurrent_Record_Type (Typ) then
         Conc_Typ := Corresponding_Concurrent_Type (Typ);

         --  Generate:
         --    I : Integer;

         --  where I will be used to capture the entry index of the primitive
         --  wrapper at position S.

         Append_To (Decls,
           Make_Object_Declaration (Loc,
             Defining_Identifier =>
               Make_Defining_Identifier (Loc, Name_uI),
             Object_Definition =>
               New_Reference_To (Standard_Integer, Loc)));

         --  Generate:
         --    C := Get_Prim_Op_Kind (tag! (<type>VP), S);

         --    if C = POK_Procedure
         --      or else C = POK_Protected_Procedure
         --      or else C = POK_Task_Procedure;
         --    then
         --       F := True;
         --       return;
         --    end if;

         SEU.Build_Common_Dispatching_Select_Statements
          (Loc, Typ, DT_Ptr, Stmts);

         --  Generate:
         --    I := Get_Entry_Index (tag! (<type>VP), S);

         --  I is the entry index and S is the dispatch table slot

         Append_To (Stmts,
           Make_Assignment_Statement (Loc,
             Name =>
               Make_Identifier (Loc, Name_uI),
             Expression =>
               Make_DT_Access_Action (Typ,
                 Action =>
                   Get_Entry_Index,
                 Args =>
                   New_List (
                     Unchecked_Convert_To (RTE (RE_Tag),
                       New_Reference_To (DT_Ptr, Loc)),
                     Make_Identifier (Loc, Name_uS)))));

         if Ekind (Conc_Typ) = E_Protected_Type then

            --  Generate:
            --    Timed_Protected_Entry_Call (
            --      T._object'access,
            --      protected_entry_index! (I),
            --      P,
            --      D,
            --      M,
            --      F);

            --  where T is the protected object, I is the entry index, P are
            --  the wrapped parameters, D is the delay amount, M is the delay
            --  mode and F is the status flag.

            Append_To (Stmts,
              Make_Procedure_Call_Statement (Loc,
                Name =>
                  New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
                Parameter_Associations =>
                  New_List (

                    Make_Attribute_Reference (Loc,        -- T._object'access
                      Attribute_Name =>
                        Name_Unchecked_Access,
                      Prefix =>
                        Make_Selected_Component (Loc,
                          Prefix =>
                            Make_Identifier (Loc, Name_uT),
                          Selector_Name =>
                            Make_Identifier (Loc, Name_uObject))),

                    Make_Unchecked_Type_Conversion (Loc,  --  entry index
                      Subtype_Mark =>
                        New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
                      Expression =>
                        Make_Identifier (Loc, Name_uI)),

                    Make_Identifier (Loc, Name_uP),       --  parameter block
                    Make_Identifier (Loc, Name_uD),       --  delay
                    Make_Identifier (Loc, Name_uM),       --  delay mode
                    Make_Identifier (Loc, Name_uF))));    --  status flag

         else
            pragma Assert (Ekind (Conc_Typ) = E_Task_Type);

            --  Generate:
            --    Timed_Task_Entry_Call (
            --      T._task_id,
            --      task_entry_index! (I),
            --      P,
            --      D,
            --      M,
            --      F);

            --  where T is the task object, I is the entry index, P are the
            --  wrapped parameters, D is the delay amount, M is the delay
            --  mode and F is the status flag.

            Append_To (Stmts,
              Make_Procedure_Call_Statement (Loc,
                Name =>
                  New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
                Parameter_Associations =>
                  New_List (

                    Make_Selected_Component (Loc,         --  T._task_id
                      Prefix =>
                        Make_Identifier (Loc, Name_uT),
                      Selector_Name =>
                        Make_Identifier (Loc, Name_uTask_Id)),

                    Make_Unchecked_Type_Conversion (Loc,  --  entry index
                      Subtype_Mark =>
                        New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
                      Expression =>
                        Make_Identifier (Loc, Name_uI)),

                    Make_Identifier (Loc, Name_uP),       --  parameter block
                    Make_Identifier (Loc, Name_uD),       --  delay
                    Make_Identifier (Loc, Name_uM),       --  delay mode
                    Make_Identifier (Loc, Name_uF))));    --  status flag
         end if;
      end if;

      return
        Make_Subprogram_Body (Loc,
          Specification =>
            Make_Disp_Timed_Select_Spec (Typ),
          Declarations =>
            Decls,
          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc, Stmts));
   end Make_Disp_Timed_Select_Body;

   ---------------------------------
   -- Make_Disp_Timed_Select_Spec --
   ---------------------------------

   function Make_Disp_Timed_Select_Spec
     (Typ : Entity_Id) return Node_Id
   is
      Loc    : constant Source_Ptr := Sloc (Typ);
      Def_Id : constant Node_Id    :=
                 Make_Defining_Identifier (Loc,
                   Name_uDisp_Timed_Select);
      Params : constant List_Id    := New_List;

   begin
      pragma Assert (not Restriction_Active (No_Dispatching_Calls));

      --  "T" - Object parameter
      --  "S" - Primitive operation slot
      --  "P" - Wrapped parameters
      --  "D" - Delay
      --  "M" - Delay Mode
      --  "C" - Call kind
      --  "F" - Status flag

      SEU.Build_T (Loc, Typ, Params);
      SEU.Build_S (Loc, Params);
      SEU.Build_P (Loc, Params);

      Append_To (Params,
        Make_Parameter_Specification (Loc,
          Defining_Identifier =>
            Make_Defining_Identifier (Loc, Name_uD),
          Parameter_Type =>
            New_Reference_To (Standard_Duration, Loc)));

      Append_To (Params,
        Make_Parameter_Specification (Loc,
          Defining_Identifier =>
            Make_Defining_Identifier (Loc, Name_uM),
          Parameter_Type =>
            New_Reference_To (Standard_Integer, Loc)));

      SEU.Build_C (Loc, Params);
      SEU.Build_F (Loc, Params);

      Set_Is_Internal (Def_Id);

      return
        Make_Procedure_Specification (Loc,
          Defining_Unit_Name       => Def_Id,
          Parameter_Specifications => Params);
   end Make_Disp_Timed_Select_Spec;

   -------------
   -- Make_DT --
   -------------

   function Make_DT (Typ : Entity_Id) return List_Id is
      Loc         : constant Source_Ptr := Sloc (Typ);
      Result      : constant List_Id    := New_List;
      Elab_Code   : constant List_Id    := New_List;

      Tname       : constant Name_Id := Chars (Typ);
      Name_DT     : constant Name_Id := New_External_Name (Tname, 'T');
      Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
      Name_SSD    : constant Name_Id := New_External_Name (Tname, 'S');
      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');
      Name_ITable : Name_Id;

      DT     : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
      DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr);
      SSD    : constant Node_Id := Make_Defining_Identifier (Loc, Name_SSD);
      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;

      Ancestor_Copy     : Entity_Id;
      Empty_DT          : Boolean := False;
      Typ_Copy          : Entity_Id;

   begin
      if not RTE_Available (RE_Tag) then
         Error_Msg_CRT ("tagged types", Typ);
         return New_List;
      end if;

      --  Calculate the size of the DT and the TSD

      if Is_Interface (Typ) then

         --  Abstract interfaces need neither the DT nor the ancestors table.
         --  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.

         Empty_DT        := True;
         Nb_Prim         := 1;
         TSD_Num_Entries := 0;
         Num_Ifaces      := 0;

      else
         --  Count the number of interfaces implemented by the ancestors

         Parent_Num_Ifaces := 0;
         Num_Ifaces        := 0;

         if Typ /= Etype (Typ) then
            Ancestor_Copy := New_Copy (Etype (Typ));
            Set_Parent (Ancestor_Copy, Parent (Etype (Typ)));
            Set_Abstract_Interfaces (Ancestor_Copy, New_Elmt_List);
            Collect_All_Interfaces (Ancestor_Copy);

            AI := First_Elmt (Abstract_Interfaces (Ancestor_Copy));
            while Present (AI) loop
               Parent_Num_Ifaces := Parent_Num_Ifaces + 1;
               Next_Elmt (AI);
            end loop;
         end if;

         --  Count the number of additional interfaces implemented by Typ

         Typ_Copy := New_Copy (Typ);
         Set_Parent (Typ_Copy, Parent (Typ));
         Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List);
         Collect_All_Interfaces (Typ_Copy);

         AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
         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.

         declare
            Parent_Type : Entity_Id := Typ;
            P           : Entity_Id;

         begin
            I_Depth := 0;
            loop
               P := Etype (Parent_Type);

               if Is_Private_Type (P) then
                  P := Full_View (Base_Type (P));
               end if;

               exit when P = Parent_Type;

               I_Depth := I_Depth + 1;
               Parent_Type := P;
            end loop;
         end;

         TSD_Num_Entries := I_Depth + 1;
         Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));

         --  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.

         if Nb_Prim = 0 or else Restriction_Active (No_Dispatching_Calls) then
            Empty_DT := True;
            Nb_Prim  := 1;
         end if;
      end if;

      --  Dispatch table and related entities are allocated statically

      Set_Ekind (DT, E_Variable);
      Set_Is_Statically_Allocated (DT);

      Set_Ekind (DT_Ptr, E_Variable);
      Set_Is_Statically_Allocated (DT_Ptr);

      if not Is_Interface (Typ)
        and then Num_Ifaces > 0
      then
         Name_ITable := New_External_Name (Tname, 'I');
         ITable      := Make_Defining_Identifier (Loc, Name_ITable);

         Set_Ekind (ITable, E_Variable);
         Set_Is_Statically_Allocated (ITable);
      end if;

      Set_Ekind (SSD, E_Variable);
      Set_Is_Statically_Allocated (SSD);

      Set_Ekind (TSD, E_Variable);
      Set_Is_Statically_Allocated (TSD);

      Set_Ekind (Exname, E_Variable);
      Set_Is_Statically_Allocated (Exname);

      Set_Ekind (No_Reg, E_Variable);
      Set_Is_Statically_Allocated (No_Reg);

      --  Generate code to create the storage for the Dispatch_Table object:

      --   DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
      --   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)));

      Append_To (Result,
        Make_Object_Declaration (Loc,
          Defining_Identifier => DT,
          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 (DT, 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 create the pointer to the dispatch table

      --    DT_Ptr : Tag := Tag!(DT'Address);

      --  According to the C++ ABI, the base of the vtable is located after a
      --  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.

      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)));

      --  Set Access_Disp_Table field to be the dispatch table pointer

      if No (Access_Disp_Table (Typ)) then
         Set_Access_Disp_Table (Typ, New_Elmt_List);
      end if;

      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)));

      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)));

      --  Generate:
      --    Set_Signature (DT_Ptr, Value);

      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 (RTE (RE_Abstract_Interface), Loc))));

      elsif RTE_Available (RE_Set_Signature) 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 (RTE (RE_Primary_DT), Loc))));
      end if;

      --  Generate code to put the Address of the TSD in the dispatch table
      --    Set_TSD (DT_Ptr, TSD);

      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))));

      --  Set the pointer to the Interfaces_Table (if any). Otherwise the
      --  corresponding access component is set to null.

      if Is_Interface (Typ) then
         null;

      elsif 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
         end if;

      --  Generate the Interface_Table object and set the access
      --  component if the TSD to it.

      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))))));

         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))));
      end if;

      --  Generate:
      --    Set_Num_Prim_Ops (T'Tag, Nb_Prim)

      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;

         if Ada_Version >= Ada_05
           and then not Is_Interface  (Typ)
           and then not Is_Abstract   (Typ)
           and then not Is_Controlled (Typ)
           and then not Restriction_Active (No_Dispatching_Calls)
         then
            --  Generate:
            --    Set_Type_Kind (T'Tag, Type_Kind (Typ));

            Append_To (Elab_Code,
              Make_DT_Access_Action (Typ,
                Action => Set_Tagged_Kind,
                Args   => New_List (
                  New_Reference_To (DT_Ptr, Loc),               -- DTptr
                  Tagged_Kind (Typ))));                         -- Value

            --  Generate the Select Specific Data table for synchronized
            --  types that implement a synchronized interface. The size
            --  of the table is constrained by the number of non-predefined
            --  primitive operations.

            if not Empty_DT
              and then Is_Concurrent_Record_Type (Typ)
              and then Implements_Interface (
                         Typ          => Typ,
                         Kind         => Any_Limited_Interface,
                         Check_Parent => True)
            then
               Append_To (Result,
                 Make_Object_Declaration (Loc,
                   Defining_Identifier => SSD,
                   Aliased_Present     => True,
                   Object_Definition   =>
                     Make_Subtype_Indication (Loc,
                       Subtype_Mark => New_Reference_To (
                         RTE (RE_Select_Specific_Data), Loc),
                       Constraint   =>
                         Make_Index_Or_Discriminant_Constraint (Loc,
                           Constraints => New_List (
                             Make_Integer_Literal (Loc, Nb_Prim))))));

               --  Set the pointer to the Select Specific Data table in the TSD

               Append_To (Elab_Code,
                 Make_DT_Access_Action (Typ,
                   Action => Set_SSD,
                   Args   => New_List (
                     New_Reference_To (DT_Ptr, Loc),            -- DTptr
                     Make_Attribute_Reference (Loc,             -- Value
                       Prefix         => New_Reference_To (SSD, Loc),
                       Attribute_Name => Name_Address))));
            end if;
         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 Typ = Etype (Typ)
        or else Is_CPP_Class (Etype (Typ))
        or else Is_Interface (Typ)
      then
         Old_Tag1 :=
           Unchecked_Convert_To (Generalized_Tag,
             Make_Integer_Literal (Loc, 0));
         Old_Tag2 :=
           Unchecked_Convert_To (Generalized_Tag,
             Make_Integer_Literal (Loc, 0));

      else
         Old_Tag1 :=
           New_Reference_To
             (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
         Old_Tag2 :=
           New_Reference_To
             (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
      end if;

      if Typ /= Etype (Typ)
        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);

         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))));
            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)))))));
            end if;
         end if;

         --  Inherit the secondary dispatch tables of the ancestor

         if not Restriction_Active (No_Dispatching_Calls)
           and then not Is_CPP_Class (Etype (Typ))
         then
            declare
               Sec_DT_Ancestor : Elmt_Id :=
                                   Next_Elmt
                                     (First_Elmt
                                        (Access_Disp_Table (Etype (Typ))));
               Sec_DT_Typ      : Elmt_Id :=
                                   Next_Elmt
                                     (First_Elmt
                                        (Access_Disp_Table (Typ)));

               procedure Copy_Secondary_DTs (Typ : Entity_Id);
               --  Local procedure required to climb through the ancestors and
               --  copy the contents of all their secondary dispatch tables.

               ------------------------
               -- Copy_Secondary_DTs --
               ------------------------

               procedure Copy_Secondary_DTs (Typ : Entity_Id) is
                  E     : Entity_Id;
                  Iface : Elmt_Id;

               begin
                  --  Climb to the ancestor (if any) handling private types

                  if Present (Full_View (Etype (Typ))) then
                     if Full_View (Etype (Typ)) /= Typ then
                        Copy_Secondary_DTs (Full_View (Etype (Typ)));
                     end if;

                  elsif Etype (Typ) /= Typ then
                     Copy_Secondary_DTs (Etype (Typ));
                  end if;

                  if Present (Abstract_Interfaces (Typ))
                    and then not Is_Empty_Elmt_List
                                   (Abstract_Interfaces (Typ))
                  then
                     Iface := First_Elmt (Abstract_Interfaces (Typ));
                     E     := First_Entity (Typ);
                     while Present (E)
                       and then Present (Node (Sec_DT_Ancestor))
                     loop
                        if Is_Tag (E) and then Chars (E) /= Name_uTag then
                           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)))));
                           end if;

                           Next_Elmt (Sec_DT_Ancestor);
                           Next_Elmt (Sec_DT_Typ);
                           Next_Elmt (Iface);
                        end if;

                        Next_Entity (E);
                     end loop;
                  end if;
               end Copy_Secondary_DTs;

            begin
               if Present (Node (Sec_DT_Ancestor)) then

                  --  Handle private types

                  if Present (Full_View (Typ)) then
                     Copy_Secondary_DTs (Full_View (Typ));
                  else
                     Copy_Secondary_DTs (Typ);
                  end if;
               end if;
            end;
         end if;
      end if;

      --  Generate:
      --    Inherit_TSD (parent'tag, DT_Ptr);

      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))));

      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))
            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;

            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_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))));
         end if;
      end if;

      --  Generate: Set_External_Tag (DT_Ptr, exname'Address);
      --  Should be the external name not the qualified name???

      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))));

         --  Generate code to register the Tag in the External_Tag hash
         --  table for the pure Ada type only.

         --        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)

         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;
      end if;

      --  Generate:
      --     if No_Reg then
      --        <elab_code>
      --        No_Reg := False;
      --     end if;

      Append_To (Elab_Code,
        Make_Assignment_Statement (Loc,
          Name       => New_Reference_To (No_Reg, Loc),
          Expression => New_Reference_To (Standard_False, Loc)));

      Append_To (Result,
        Make_Implicit_If_Statement (Typ,
          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.

      if not Is_Interface (Typ)
        and then Num_Ifaces > 0
      then
         declare
            Position : Int;

         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 Is_Interface (Etype (Typ)) then
               Position := 1;

               AI := First_Elmt (Abstract_Interfaces (Ancestor_Copy));
               while Present (AI) loop
                  --  Generate:
                  --    Register_Interface (DT_Ptr, Interface'Tag);

                  Append_To (Result,
                    Make_DT_Access_Action (Typ,
                      Action => Register_Interface_Tag,
                      Args   => New_List (
                        Node1 => New_Reference_To (DT_Ptr, Loc),
                        Node2 => New_Reference_To
                                   (Node
                                    (First_Elmt
                                     (Access_Disp_Table (Node (AI)))),
                                    Loc),
                        Node3 => Make_Integer_Literal (Loc, Position))));

                  Position := Position + 1;
                  Next_Elmt (AI);
               end loop;
            end if;

            --  Register the interfaces that are not implemented by the
            --  ancestor

            if Present (Abstract_Interfaces (Typ_Copy)) then
               AI := First_Elmt (Abstract_Interfaces (Typ_Copy));

               --  Skip the interfaces implemented by the ancestor

               for Count in 1 .. Parent_Num_Ifaces loop
                  Next_Elmt (AI);
               end loop;

               --  Register the additional interfaces

               Position := Parent_Num_Ifaces + 1;
               while Present (AI) loop
                  --  Generate:
                  --    Register_Interface (DT_Ptr, Interface'Tag);

                  Append_To (Result,
                    Make_DT_Access_Action (Typ,
                      Action => Register_Interface_Tag,
                      Args   => New_List (
                        Node1 => New_Reference_To (DT_Ptr, Loc),
                        Node2 => New_Reference_To
                                   (Node
                                    (First_Elmt
                                     (Access_Disp_Table (Node (AI)))),
                                    Loc),
                        Node3 => Make_Integer_Literal (Loc, Position))));

                  Position := Position + 1;
                  Next_Elmt (AI);
               end loop;
            end if;

            pragma Assert (Position = Num_Ifaces + 1);
         end;
      end if;

      return Result;
   end Make_DT;

   ---------------------------
   -- Make_DT_Access_Action --
   ---------------------------

   function Make_DT_Access_Action
     (Typ    : Entity_Id;
      Action : DT_Access_Action;
      Args   : List_Id) return Node_Id
   is
      Action_Name : constant Entity_Id := RTE (Ada_Actions (Action));
      Loc         : Source_Ptr;

   begin
      if No (Args) then

         --  This is a constant

         return New_Reference_To (Action_Name, Sloc (Typ));
      end if;

      pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));

      Loc := Sloc (First (Args));

      if Action_Is_Proc (Action) then
         return
           Make_Procedure_Call_Statement (Loc,
             Name => New_Reference_To (Action_Name, Loc),
             Parameter_Associations => Args);

      else
         return
           Make_Function_Call (Loc,
             Name => New_Reference_To (Action_Name, Loc),
             Parameter_Associations => Args);
      end if;
   end Make_DT_Access_Action;

   -----------------------
   -- Make_Secondary_DT --
   -----------------------

   procedure Make_Secondary_DT
     (Typ             : Entity_Id;
      Ancestor_Typ    : Entity_Id;
      Suffix_Index    : Int;
      Iface           : Entity_Id;
      AI_Tag          : Entity_Id;
      Acc_Disp_Tables : in out Elist_Id;
      Result          : out List_Id)
   is
      Loc             : constant Source_Ptr := Sloc (AI_Tag);
      Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
      Name_DT         : constant Name_Id := New_Internal_Name ('T');
      Empty_DT        : Boolean := False;
      Iface_DT        : Node_Id;
      Iface_DT_Ptr    : Node_Id;
      Name_DT_Ptr     : Name_Id;
      Nb_Prim         : Int;
      OSD             : Entity_Id;
      Size_Expr_Node  : Node_Id;
      Tname           : Name_Id;

   begin
      Result := New_List;

      --  Generate a unique external name associated with the secondary
      --  dispatch table. This external name will be used to declare an
      --  access to this secondary dispatch table, value that will be used
      --  for the elaboration of Typ's objects and also for the elaboration
      --  of objects of any derivation of Typ that do not override any
      --  primitive operation of Typ.

      Get_Secondary_DT_External_Name (Typ, Ancestor_Typ, Suffix_Index);

      Tname        := Name_Find;
      Name_DT_Ptr  := New_External_Name (Tname, "P");
      Iface_DT     := Make_Defining_Identifier (Loc, Name_DT);
      Iface_DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr);

      --  Dispatch table and related entities are allocated statically

      Set_Ekind (Iface_DT, E_Variable);
      Set_Is_Statically_Allocated (Iface_DT);

      Set_Ekind (Iface_DT_Ptr, E_Variable);
      Set_Is_Statically_Allocated (Iface_DT_Ptr);

      --  Generate code to create the storage for the Dispatch_Table object.
      --  If the number of primitives of Typ is 0 we reserve a dummy single
      --  entry for its DT because at run-time the pointer to this dummy entry
      --  will be used as the tag.

      Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));

      if Nb_Prim = 0 then
         Empty_DT := True;
         Nb_Prim  := 1;
      end if;

      --    DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
      --    for DT'Alignment use Address'Alignment

      Size_Expr_Node :=
        Make_Op_Add (Loc,
          Left_Opnd  => Make_DT_Access_Action (Etype (AI_Tag),
                          DT_Prologue_Size,
                          No_List),
          Right_Opnd =>
            Make_Op_Multiply (Loc,
              Left_Opnd  =>
                Make_DT_Access_Action (Etype (AI_Tag),
                                       DT_Entry_Size,
                                       No_List),
              Right_Opnd =>
                Make_Integer_Literal (Loc, Nb_Prim)));

      Append_To (Result,
        Make_Object_Declaration (Loc,
          Defining_Identifier => Iface_DT,
          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 (Iface_DT, 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 create the pointer to the dispatch table

      --    Iface_DT_Ptr : Tag := Tag!(DT'Address);

      --  According to the C++ ABI, the base of the vtable is located
      --  after the following prologue: Offset_To_Top, and Typeinfo_Ptr.
      --  Hence, move the pointer down to the real base of the vtable.

      Append_To (Result,
        Make_Object_Declaration (Loc,
          Defining_Identifier => Iface_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 (Iface_DT, Loc),
                      Attribute_Name => Name_Address)),
                Right_Opnd =>
                  Make_DT_Access_Action (Etype (AI_Tag),
                    DT_Prologue_Size, No_List)))));

      --  Note: Offset_To_Top will be initialized by the init subprogram

      --  Set Access_Disp_Table field to be the dispatch table pointer

      if not (Present (Acc_Disp_Tables)) then
         Acc_Disp_Tables := New_Elmt_List;
      end if;

      Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables);

      --  Step 1: Generate an Object Specific Data (OSD) table

      OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));

      --  Nothing to do if configurable run time does not support the
      --  Object_Specific_Data entity.

      if not RTE_Available (RE_Object_Specific_Data) then
         Error_Msg_CRT ("abstract interface types", Typ);
         return;
      end if;

      --  Generate:
      --    OSD : Ada.Tags.Object_Specific_Data (Nb_Prims);
      --  where the constraint is used to allocate space for the
      --  non-predefined primitive operations only.

      Append_To (Result,
        Make_Object_Declaration (Loc,
          Defining_Identifier => OSD,
          Object_Definition   =>
            Make_Subtype_Indication (Loc,
              Subtype_Mark => New_Reference_To (
                RTE (RE_Object_Specific_Data), Loc),
              Constraint =>
                Make_Index_Or_Discriminant_Constraint (Loc,
                  Constraints => New_List (
                    Make_Integer_Literal (Loc, Nb_Prim))))));

      Append_To (Result,
        Make_DT_Access_Action (Typ,
          Action => Set_Signature,
          Args   => New_List (
            Unchecked_Convert_To (RTE (RE_Tag),
              New_Reference_To (Iface_DT_Ptr, Loc)),
            New_Reference_To (RTE (RE_Secondary_DT), Loc))));

      --  Generate:
      --    Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD);

      Append_To (Result,
        Make_DT_Access_Action (Typ,
          Action => Set_OSD,
          Args   => New_List (
            Unchecked_Convert_To (RTE (RE_Tag),
              New_Reference_To (Iface_DT_Ptr, Loc)),
            Make_Attribute_Reference (Loc,
              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_Controlled (Typ)
        and then RTE_Available (RE_Set_Tagged_Kind)
        and then not Restriction_Active (No_Dispatching_Calls)
      then
         --  Generate:
         --    Set_Tagged_Kind (Iface'Tag, Tagged_Kind (Iface));

         Append_To (Result,
           Make_DT_Access_Action (Typ,
             Action => Set_Tagged_Kind,
             Args   => New_List (
               Unchecked_Convert_To (RTE (RE_Tag),              -- DTptr
                 New_Reference_To (Iface_DT_Ptr, Loc)),
               Tagged_Kind (Typ))));                            -- Value

         if not Empty_DT
           and then Is_Concurrent_Record_Type (Typ)
           and then Implements_Interface (
                      Typ          => Typ,
                      Kind         => Any_Limited_Interface,
                      Check_Parent => True)
         then
            declare
               Prim       : Entity_Id;
               Prim_Alias : Entity_Id;
               Prim_Elmt  : Elmt_Id;

            begin
               --  Step 2: Populate the OSD table

               Prim_Alias := Empty;
               Prim_Elmt  := First_Elmt (Primitive_Operations (Typ));
               while Present (Prim_Elmt) loop
                  Prim := Node (Prim_Elmt);

                  if Present (Abstract_Interface_Alias (Prim)) then
                     Prim_Alias := Abstract_Interface_Alias (Prim);
                  end if;

                  if Present (Prim_Alias)
                    and then Present (First_Entity (Prim_Alias))
                    and then Etype (First_Entity (Prim_Alias)) = Iface
                  then
                     --  Generate:
                     --    Ada.Tags.Set_Offset_Index (Tag (Iface_DT_Ptr),
                     --      Secondary_DT_Pos, Primary_DT_pos);

                     Append_To (Result,
                       Make_DT_Access_Action (Iface,
                         Action => Set_Offset_Index,
                         Args   => New_List (
                           Unchecked_Convert_To (RTE (RE_Tag),
                             New_Reference_To (Iface_DT_Ptr, Loc)),
                           Make_Integer_Literal (Loc,
                             DT_Position (Prim_Alias)),
                           Make_Integer_Literal (Loc,
                             DT_Position (Prim)))));

                     Prim_Alias := Empty;
                  end if;

                  Next_Elmt (Prim_Elmt);
               end loop;
            end;
         end if;
      end if;
   end Make_Secondary_DT;

   -------------------------------------
   -- Make_Select_Specific_Data_Table --
   -------------------------------------

   function Make_Select_Specific_Data_Table
     (Typ : Entity_Id) return List_Id
   is
      Assignments : constant List_Id    := New_List;
      Loc         : constant Source_Ptr := Sloc (Typ);

      Conc_Typ  : Entity_Id;
      Decls     : List_Id;
      DT_Ptr    : Entity_Id;
      Prim      : Entity_Id;
      Prim_Als  : Entity_Id;
      Prim_Elmt : Elmt_Id;
      Prim_Pos  : Uint;
      Nb_Prim   : Int := 0;

      type Examined_Array is array (Int range <>) of Boolean;

      function Find_Entry_Index (E : Entity_Id) return Uint;
      --  Given an entry, find its index in the visible declarations of the
      --  corresponding concurrent type of Typ.

      ----------------------
      -- Find_Entry_Index --
      ----------------------

      function Find_Entry_Index (E : Entity_Id) return Uint is
         Index     : Uint := Uint_1;
         Subp_Decl : Entity_Id;

      begin
         if Present (Decls)
           and then not Is_Empty_List (Decls)
         then
            Subp_Decl := First (Decls);
            while Present (Subp_Decl) loop
               if Nkind (Subp_Decl) = N_Entry_Declaration then
                  if Defining_Identifier (Subp_Decl) = E then
                     return Index;
                  end if;

                  Index := Index + 1;
               end if;

               Next (Subp_Decl);
            end loop;
         end if;

         return Uint_0;
      end Find_Entry_Index;

   --  Start of processing for Make_Select_Specific_Data_Table

   begin
      pragma Assert (not Restriction_Active (No_Dispatching_Calls));

      DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));

      if Present (Corresponding_Concurrent_Type (Typ)) then
         Conc_Typ := Corresponding_Concurrent_Type (Typ);

         if Ekind (Conc_Typ) = E_Protected_Type then
            Decls := Visible_Declarations (Protected_Definition (
                       Parent (Conc_Typ)));
         else
            pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
            Decls := Visible_Declarations (Task_Definition (
                       Parent (Conc_Typ)));
         end if;
      end if;

      --  Count the non-predefined primitive operations

      Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
      while Present (Prim_Elmt) loop
         if not Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then
            Nb_Prim := Nb_Prim + 1;
         end if;

         Next_Elmt (Prim_Elmt);
      end loop;

      declare
         Examined : Examined_Array (1 .. Nb_Prim) := (others => False);

      begin
         Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
         while Present (Prim_Elmt) loop
            Prim := Node (Prim_Elmt);
            Prim_Pos := DT_Position (Prim);

            if not Is_Predefined_Dispatching_Operation (Prim) then
               pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);

               if Examined (UI_To_Int (Prim_Pos)) then
                  goto Continue;
               else
                  Examined (UI_To_Int (Prim_Pos)) := True;
               end if;

               --  The current primitive overrides an interface-level
               --  subprogram

               if Present (Abstract_Interface_Alias (Prim)) then

                  --  Set the primitive operation kind regardless of subprogram
                  --  type. Generate:
                  --    Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);

                  Append_To (Assignments,
                    Make_DT_Access_Action (Typ,
                      Action =>
                        Set_Prim_Op_Kind,
                      Args =>
                        New_List (
                          New_Reference_To (DT_Ptr, Loc),
                          Make_Integer_Literal (Loc, Prim_Pos),
                          Prim_Op_Kind (Prim, Typ))));

                  --  Retrieve the root of the alias chain if one is present

                  if Present (Alias (Prim)) then
                     Prim_Als := Prim;
                     while Present (Alias (Prim_Als)) loop
                        Prim_Als := Alias (Prim_Als);
                     end loop;
                  else
                     Prim_Als := Empty;
                  end if;

                  --  In the case of an entry wrapper, set the entry index

                  if Ekind (Prim) = E_Procedure
                    and then Present (Prim_Als)
                    and then Is_Primitive_Wrapper (Prim_Als)
                    and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
                  then

                     --  Generate:
                     --    Ada.Tags.Set_Entry_Index
                     --      (DT_Ptr, <position>, <index>);

                     Append_To (Assignments,
                       Make_DT_Access_Action (Typ,
                         Action =>
                           Set_Entry_Index,
                         Args =>
                           New_List (
                             New_Reference_To (DT_Ptr, Loc),
                             Make_Integer_Literal (Loc, Prim_Pos),
                             Make_Integer_Literal (Loc,
                               Find_Entry_Index
                                 (Wrapped_Entity (Prim_Als))))));
                  end if;
               end if;
            end if;

            <<Continue>>

            Next_Elmt (Prim_Elmt);
         end loop;
      end;

      return Assignments;
   end Make_Select_Specific_Data_Table;

   -----------------------------------
   -- Original_View_In_Visible_Part --
   -----------------------------------

   function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
      Scop : constant Entity_Id := Scope (Typ);

   begin
      --  The scope must be a package

      if Ekind (Scop) /= E_Package
        and then Ekind (Scop) /= E_Generic_Package
      then
         return False;
      end if;

      --  A type with a private declaration has a private view declared in
      --  the visible part.

      if Has_Private_Declaration (Typ) then
         return True;
      end if;

      return List_Containing (Parent (Typ)) =
        Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
   end Original_View_In_Visible_Part;

   ------------------
   -- Prim_Op_Kind --
   ------------------

   function Prim_Op_Kind
     (Prim : Entity_Id;
      Typ  : Entity_Id) return Node_Id
   is
      Full_Typ : Entity_Id := Typ;
      Loc      : constant Source_Ptr := Sloc (Prim);
      Prim_Op  : Entity_Id;

   begin
      --  Retrieve the original primitive operation

      Prim_Op := Prim;
      while Present (Alias (Prim_Op)) loop
         Prim_Op := Alias (Prim_Op);
      end loop;

      if Ekind (Typ) = E_Record_Type
        and then Present (Corresponding_Concurrent_Type (Typ))
      then
         Full_Typ := Corresponding_Concurrent_Type (Typ);
      end if;

      if Ekind (Prim_Op) = E_Function then

         --  Protected function

         if Ekind (Full_Typ) = E_Protected_Type then
            return New_Reference_To (RTE (RE_POK_Protected_Function), Loc);

         --  Task function

         elsif Ekind (Full_Typ) = E_Task_Type then
            return New_Reference_To (RTE (RE_POK_Task_Function), Loc);

         --  Regular function

         else
            return New_Reference_To (RTE (RE_POK_Function), Loc);
         end if;

      else
         pragma Assert (Ekind (Prim_Op) = E_Procedure);

         if Ekind (Full_Typ) = E_Protected_Type then

            --  Protected entry

            if Is_Primitive_Wrapper (Prim_Op)
              and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
            then
               return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc);

            --  Protected procedure

            else
               return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc);
            end if;

         elsif Ekind (Full_Typ) = E_Task_Type then

            --  Task entry

            if Is_Primitive_Wrapper (Prim_Op)
              and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
            then
               return New_Reference_To (RTE (RE_POK_Task_Entry), Loc);

            --  Task "procedure". These are the internally Expander-generated
            --  procedures (task body for instance).

            else
               return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc);
            end if;

         --  Regular procedure

         else
            return New_Reference_To (RTE (RE_POK_Procedure), Loc);
         end if;
      end if;
   end Prim_Op_Kind;

   -------------------------
   -- Set_All_DT_Position --
   -------------------------

   procedure Set_All_DT_Position (Typ : Entity_Id) is
      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;
      Prim       : Entity_Id;
      Prim_Elmt  : Elmt_Id;

      procedure Validate_Position (Prim : Entity_Id);
      --  Check that the position assignated to Prim is completely safe
      --  (it has not been assigned to a previously defined primitive
      --   operation of Typ)

      -----------------------
      -- Validate_Position --
      -----------------------

      procedure Validate_Position (Prim : Entity_Id) is
         Prim_Elmt : Elmt_Id;

      begin
         Prim_Elmt :=  First_Elmt (Primitive_Operations (Typ));
         while Present (Prim_Elmt)
            and then Node (Prim_Elmt) /= Prim
         loop
            --  Primitive operations covering abstract interfaces are
            --  allocated later

            if Present (Abstract_Interface_Alias (Node (Prim_Elmt))) then
               null;

            --  Predefined dispatching operations are completely safe. They
            --  are allocated at fixed positions in a separate table.

            elsif Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then
               null;

            --  Aliased subprograms are safe

            elsif Present (Alias (Prim)) then
               null;

            elsif DT_Position (Node (Prim_Elmt)) = DT_Position (Prim) then

               --  Handle aliased subprograms

               declare
                  Op_1 : Entity_Id;
                  Op_2 : Entity_Id;

               begin
                  Op_1 := Node (Prim_Elmt);
                  loop
                     if Present (Overridden_Operation (Op_1)) then
                        Op_1 := Overridden_Operation (Op_1);
                     elsif Present (Alias (Op_1)) then
                        Op_1 := Alias (Op_1);
                     else
                        exit;
                     end if;
                  end loop;

                  Op_2 := Prim;
                  loop
                     if Present (Overridden_Operation (Op_2)) then
                        Op_2 := Overridden_Operation (Op_2);
                     elsif Present (Alias (Op_2)) then
                        Op_2 := Alias (Op_2);
                     else
                        exit;
                     end if;
                  end loop;

                  if Op_1 /= Op_2 then
                     raise Program_Error;
                  end if;
               end;
            end if;

            Next_Elmt (Prim_Elmt);
         end loop;
      end Validate_Position;

   --  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) 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)));

            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

               --  Get the slot from the parent subprogram if any

               declare
                  H : Entity_Id;

               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;

               --  Otherwise take the canonical slot after the end of the
               --  parent Vtable

               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;

            Next_Elmt (Prim_Elmt);
         end loop;

         --  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).

         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));

         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;

         --  Check that Positions are not duplicate nor outside the range of
         --  the Vtable.

         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);

         begin
            Prim_Elmt := First_Prim;
            while Present (Prim_Elmt) loop
               Prim := Node (Prim_Elmt);

               if DTC_Entity (Prim) = The_Tag then
                  Pos := UI_To_Int (DT_Position (Prim));

                  if Pos not in Prim_Pos_Table'Range then
                     Error_Msg_N
                       ("position not in range of virtual table", Prim);

                  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));

                  else
                     Prim_Pos_Table (Pos) := Prim;
                  end if;
               end if;

               Next_Elmt (Prim_Elmt);
            end loop;
         end;

         --  Generate listing showing the contents of the dispatch tables

         if Debug_Flag_ZZ then
            Write_DT (Typ);
         end if;

      --  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.

      --  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).

      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.

         Prim_Elmt  := First_Prim;
         Count_Prim := 0;
         while Present (Prim_Elmt) loop
            Count_Prim := Count_Prim + 1;
            Prim       := Node (Prim_Elmt);

            --  Ada 2005 (AI-251)

            if Present (Abstract_Interface_Alias (Prim))
              and then Is_Interface (Scope (DTC_Entity
                                      (Abstract_Interface_Alias (Prim))))
            then
               Set_DTC_Entity (Prim,
                  Find_Interface_Tag
                    (T => Typ,
                     Iface => Scope (DTC_Entity
                                      (Abstract_Interface_Alias (Prim)))));

            else
               Set_DTC_Entity (Prim, The_Tag);
            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 .. Parent_EC + Count_Prim)
                           of Boolean := (others => False);

            E : Entity_Id;

         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));

               --  Overriding interface primitives of an ancestor

               elsif DT_Position (Prim) = No_Uint
                 and then Present (Abstract_Interface_Alias (Prim))
                 and then Present (DTC_Entity
                                   (Abstract_Interface_Alias (Prim)))
                 and then DT_Position (Abstract_Interface_Alias (Prim))
                                        /= No_Uint
                 and then Is_Inherited_Operation (Prim)
                 and then Is_Ancestor (Scope
                                       (DTC_Entity
                                        (Abstract_Interface_Alias (Prim))),
                                       Typ)
               then
                  Set_DT_Position (Prim,
                    DT_Position (Abstract_Interface_Alias (Prim)));
                  Set_DT_Position (Alias (Prim),
                    DT_Position (Abstract_Interface_Alias (Prim)));
                  Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True;

               --  Overriding primitives must use the same entry as the
               --  overriden primitive

               elsif DT_Position (Prim) = No_Uint
                 and then Present (Alias (Prim))
                 and then Present (DTC_Entity (Alias (Prim)))
                 and then DT_Position (Alias (Prim)) /= No_Uint
                 and then Is_Inherited_Operation (Prim)
                 and then Is_Ancestor (Scope (DTC_Entity (Alias (Prim))), Typ)
               then
                  E := Alias (Prim);
                  while not (Present (DTC_Entity (E))
                              or else DT_Position (E) = No_Uint)
                    and then Present (Alias (E))
                  loop
                     E := Alias (E);
                  end loop;

                  pragma Assert (Present (DTC_Entity (E))
                                   and then
                                 DT_Position (E) /= No_Uint);

                  Set_DT_Position (Prim, DT_Position (E));
                  Fixed_Prim (UI_To_Int (DT_Position (E))) := True;

                  --  If this is not the last element in the chain continue
                  --  traversing the chain. This is required to properly
                  --  handling renamed primitives

                  while Present (Alias (E)) loop
                     E   := Alias (E);
                     Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
                  end loop;
               end if;

               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.

            Prim_Elmt := First_Prim;
            while Present (Prim_Elmt) loop
               Prim := Node (Prim_Elmt);

               --  Skip primitives previously set entries

               if Is_Predefined_Dispatching_Operation (Prim) then
                  null;

               elsif DT_Position (Prim) /= No_Uint then
                  null;

               elsif Etype (DTC_Entity (Prim)) /= RTE (RE_Tag) then
                  null;

               --  Primitives covering interface primitives are
               --  handled later

               elsif Present (Abstract_Interface_Alias (Prim)) then
                  null;

               else
                  --  Take the next available position in the DT

                  loop
                     Nb_Prim := Nb_Prim + 1;
                     exit when not Fixed_Prim (Nb_Prim);
                  end loop;

                  Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
                  Fixed_Prim (Nb_Prim) := True;
               end if;

               Next_Elmt (Prim_Elmt);
            end loop;
         end;

         --  Fourth stage: Complete the decoration of primitives covering
         --  interfaces (that is, propagate the DT_Position attribute
         --  from the aliased primitive)

         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))
            then
               --  Check if this entry will be placed in the primary DT

               if Etype (DTC_Entity (Abstract_Interface_Alias (Prim)))
                    = RTE (RE_Tag)
               then
                  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

               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.

         if Debug_Flag_ZZ then
            Write_DT (Typ);
         end if;

         --  Final stage: Ensure that the table is correct plus some further
         --  verifications concerning the primitives.

         Prim_Elmt := First_Prim;
         DT_Length := 0;
         while Present (Prim_Elmt) loop
            Prim := Node (Prim_Elmt);

            --  At this point all the primitives MUST have a position
            --  in the dispatch table

            if DT_Position (Prim) = No_Uint then
               raise Program_Error;
            end if;

            --  Calculate real size of the dispatch table

            if not Is_Predefined_Dispatching_Operation (Prim)
              and then UI_To_Int (DT_Position (Prim)) > DT_Length
            then
               DT_Length := UI_To_Int (DT_Position (Prim));
            end if;

            --  Ensure that the asignated position to non-predefined
            --  dispatching operations in the dispatch table is correct.

            if not Is_Predefined_Dispatching_Operation (Prim) then
               Validate_Position (Prim);
            end if;

            if Chars (Prim) = Name_Finalize then
               Finalized := True;
            end if;

            if Chars (Prim) = Name_Adjust then
               Adjusted := 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. Input is excluded
            --  because

            if Is_Abstract (Typ)
              and then Is_Abstract (Prim)
              and then Present (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 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;
            end if;

            Next_Elmt (Prim_Elmt);
         end loop;

         --  Additional check

         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;
         end if;

         --  Set the final size of the Dispatch Table

         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)

         --  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;
      end if;
   end Set_All_DT_Position;

   -----------------------------
   -- Set_Default_Constructor --
   -----------------------------

   procedure Set_Default_Constructor (Typ : Entity_Id) is
      Loc   : Source_Ptr;
      Init  : Entity_Id;
      Param : Entity_Id;
      E     : Entity_Id;

   begin
      --  Look for the default constructor entity. For now only the
      --  default constructor has the flag Is_Constructor.

      E := Next_Entity (Typ);
      while Present (E)
        and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
      loop
         Next_Entity (E);
      end loop;

      --  Create the init procedure

      if Present (E) then
         Loc   := Sloc (E);
         Init  := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
         Param := Make_Defining_Identifier (Loc, Name_X);

         Discard_Node (
           Make_Subprogram_Declaration (Loc,
             Make_Procedure_Specification (Loc,
               Defining_Unit_Name => Init,
               Parameter_Specifications => New_List (
                 Make_Parameter_Specification (Loc,
                   Defining_Identifier => Param,
                   Parameter_Type      => New_Reference_To (Typ, Loc))))));

         Set_Init_Proc (Typ, Init);
         Set_Is_Imported    (Init);
         Set_Interface_Name (Init, Interface_Name (E));
         Set_Convention     (Init, Convention_C);
         Set_Is_Public      (Init);
         Set_Has_Completion (Init);

      --  If there are no constructors, mark the type as abstract since we
      --  won't be able to declare objects of that type.

      else
         Set_Is_Abstract (Typ);
      end if;
   end Set_Default_Constructor;

   -----------------
   -- Tagged_Kind --
   -----------------

   function Tagged_Kind (T : Entity_Id) return Node_Id is
      Conc_Typ : Entity_Id;
      Loc      : constant Source_Ptr := Sloc (T);

   begin
      pragma Assert
        (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));

      --  Abstract kinds

      if Is_Abstract (T) then
         if Is_Limited_Record (T) then
            return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
         else
            return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc);
         end if;

      --  Concurrent kinds

      elsif Is_Concurrent_Record_Type (T) then
         Conc_Typ := Corresponding_Concurrent_Type (T);

         if Ekind (Conc_Typ) = E_Protected_Type then
            return New_Reference_To (RTE (RE_TK_Protected), Loc);
         else
            pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
            return New_Reference_To (RTE (RE_TK_Task), Loc);
         end if;

      --  Regular tagged kinds

      else
         if Is_Limited_Record (T) then
            return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc);
         else
            return New_Reference_To (RTE (RE_TK_Tagged), Loc);
         end if;
      end if;
   end Tagged_Kind;

   --------------
   -- Write_DT --
   --------------

   procedure Write_DT (Typ : Entity_Id) is
      Elmt : Elmt_Id;
      Prim : Node_Id;

   begin
      --  Protect this procedure against wrong usage. Required because it will
      --  be used directly from GDB

      --  LLVM local
      if not (Typ <= Last_Node_Id)
        or else not Is_Tagged_Type (Typ)
      then
         Write_Str ("wrong usage: Write_DT must be used with tagged types");
         Write_Eol;
         return;
      end if;

      Write_Int (Int (Typ));
      Write_Str (": ");
      Write_Name (Chars (Typ));

      if Is_Interface (Typ) then
         Write_Str (" is interface");
      end if;

      Write_Eol;

      Elmt := First_Elmt (Primitive_Operations (Typ));
      while Present (Elmt) loop
         Prim := Node (Elmt);
         Write_Str  (" - ");

         --  Indicate if this primitive will be allocated in the primary
         --  dispatch table or in a secondary dispatch table associated
         --  with an abstract interface type

         if Present (DTC_Entity (Prim)) then
            if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
               Write_Str ("[P] ");
            else
               Write_Str ("[s] ");
            end if;
         end if;

         --  Output the node of this primitive operation and its name

         Write_Int  (Int (Prim));
         Write_Str  (": ");

         if Is_Predefined_Dispatching_Operation (Prim) then
            Write_Str ("(predefined) ");
         end if;

         Write_Name (Chars (Prim));

         --  Indicate if this primitive has an aliased primitive

         if Present (Alias (Prim)) then
            Write_Str (" (alias = ");
            Write_Int (Int (Alias (Prim)));

            --  If the DTC_Entity attribute is already set we can also output
            --  the name of the interface covered by this primitive (if any)

            if Present (DTC_Entity (Alias (Prim)))
              and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
            then
               Write_Str  (" from interface ");
               Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
            end if;

            if Present (Abstract_Interface_Alias (Prim)) then
               Write_Str  (", AI_Alias of ");
               Write_Name (Chars (Scope (DTC_Entity
                                          (Abstract_Interface_Alias (Prim)))));
               Write_Char (':');
               Write_Int  (Int (Abstract_Interface_Alias (Prim)));
            end if;

            Write_Str (")");
         end if;

         --  Display the final position of this primitive in its associated
         --  (primary or secondary) dispatch table

         if Present (DTC_Entity (Prim))
           and then DT_Position (Prim) /= No_Uint
         then
            Write_Str (" at #");
            Write_Int (UI_To_Int (DT_Position (Prim)));
         end if;

         if Is_Abstract (Prim) then
            Write_Str (" is abstract;");
         end if;

         Write_Eol;

         Next_Elmt (Elmt);
      end loop;
   end Write_DT;

end Exp_Disp;