a-tags.adb (IW_Membership): Give support to "Iface_CW_Typ in T'Class".

2005-09-01  Hristian Kirtchev  <kirtchev@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* a-tags.adb (IW_Membership): Give support to
	"Iface_CW_Typ in T'Class". For this purpose the functionality of this
	subprogram has been extended to look for the tag in the ancestors tag
	table.
	Update the structure of the GNAT Dispatch Table to reflect the
	additional two tables used in dispatching selects.
	Introduce appropriate array types and record components in
	Type_Specific_Data to reflect the two tables.
	(Get_Entry_Index, Set_Entry_Index): Retrieve and set the entry index in
	the TSD of a tag, indexed by position.
	(Get_Prim_Op_Kind, Set_Prim_Op_Kind): Retrieve and set the primitive
	operation kind in the TSD of a tag, indexed by position.

	* a-tags.ads: Introduce an enumeration type to capture different
	primitive operation kinds. Define a constant reflecting the number of
	predefined primitive operations.
	(Get_Entry_Index, Set_Entry_Index): Set and retrieve the entry index
	of an entry wrapper.
	(Get_Prim_Op_Kind, Set_Prim_Op_Kind): Set and retrieve the kind of
	callable entity of a primitive operation.

	* exp_ch3.adb (Freeze_Record_Type): Generate the declarations of the
	primitive operations used in dispatching selects for limited
	interfaces, limited tagged, task and protected types what implement a
	limited interface.
	(Freeze_Type): Generate the bodies of the primitive operations used in
	dispatching selects for limited tagged, task and protected types that
	implement a limited interface. Generate statements to populate the two
	auxiliary tables used for dispatching in select statements.
	(Freeze_Record_Type): Add call to initialize the dispatch table entries
	associated with predefined interface primitive operations.
	(Build_Dcheck_Function): Change Set_Subtype_Mark to
	Set_Result_Definition.
	(Build_Variant_Record_Equality): Change Subtype_Mark to
	Result_Definition.
	(Freeze_Enumeration_Type): Change Subtype_Mark to Result_Definition.
	(Predef_Spec_Or_Body): Change Subtype_Mark to Result_Definition.
	(Build_Assignment): Simplify the code that adds the run-time-check.
	(Expand_N_Object_Declaration): Code cleanup.

	* exp_ch7.adb (Make_Clean): Select the appropriate type for locking
	entries when there is a protected type that implements a limited
	interface.

	* exp_ch9.adb: Add package Select_Expansion_Utilities that contains
	common routines used in expansion of dispatching selects.
	(Add_Private_Declarations): Select the appropriate protection type when
	there is a protected type that implements a limited interface.
	(Build_Parameter_Block): Generate a wrapped parameter block.
	(Build_Protected_Subprogram_Body): Select the appropriate type for
	locking entries when there is a protected type that implements a
	limited interface.
	(Build_Wrapper_Spec): Set the flag and wrapped entity for procedures
	classified as entry wrappers.
	(Expand_N_Asynchronous_Select): Add support for expansion of dispatching
	asynchronous selects.
	(Expand_N_Conditional_Entry_Call): Add support for expansion of
	dispatching conditional selects.
	(Expand_N_Protected_Type_Declaration): Select the appropriate type for
	protection when there is a protected type that implements limited
	interfaces.
	(Expand_N_Timed_Entry_Call): Add support for expansion of dispatching
	timed selects.
	(Extract_Dispatching_Call): Extract the entity of the name of a
	dispatching call, the object parameter, actual parameters and
	corresponding formals.
	(Make_Initialize_Protection): Correct logic of protection initialization
	when there is a protected type that implements a limited interface.
	(Parameter_Block_Pack): Populate a wrapped parameter block with the
	values of actual parameters.
	(Parameter_Block_Unpack): Retrieve the values from a wrapped parameter
	block and assign them to the original actual parameters.

	* exp_ch9.ads (Subprogram_Protection_Mode): New type.
	(Build_Protected_Sub_Specification): Change the type and name of the
	last formal to account for the increased variety of protection modes.

	* einfo.ads, einfo.adb (Was_Hidden): New attribute. Present in all
	entities. Used to save the value of the Is_Hidden attribute when the
	limited-view is installed.
	(Is_Primitive_Wrapper, Set_Is_Primitive_Wrapper): Retrieve and change
	the attribute of procedures classified as entry wrappers.
	(Wrapped_Entity, Set_Wrapped_Entity): Retrieve and change the wrapped
	entity of a primitive wrapper.
	(Write_Entity_Flags): Output the name and value of the
	Is_Primitive_Wrapper attribute.
	(Write_Field27_Name): Output the name and entity of the field Wrapped_
	Entity.
	(Underlying_Type): If we have an incomplete entity that comes from
	the limited view then we return the Underlying_Type of its non-limited
	view if it is already available.
	(Abstract_Interface_Alias): Flag applies to all subrogram kinds,
	including operators.
	(Write_Field26_Name): Add entry for Overridden_Operation
	(Overridden_Operation): New attribute of functions and procedures.

	* exp_disp.ads, exp_disp.adb (Default_Prim_Op_Position): Return a
	predefined position in the dispatch table for the primitive operations
	used in dispatching selects.
	(Init_Predefined_Interface_Primitives): Remove the hardcoded number of
	predefined primitive operations and replace it with
	Default_Prim_Op_Count.
	(Make_Disp_Asynchronous_Select_Spec, Make_Disp_Conditional_Select_Spec,
	Make_Disp_Get_Prim_Op_Kind_Spec, Make_Disp_Timed_Select_Spec): Update
	the names of the generated primitive operations used in dispatching
	selects.
	(Init_Predefined_Interface_Primitives): No need to inherit primitives in
	case of abstract interface types. They will be inherit by the objects
	implementing the interface.
	(Make_DT): There is no need to inherit the dispatch table of the
	ancestor interface for the elaboration of abstract interface types.
	The dispatch table will be inherited by the object implementing the
	interface.
	(Copy_Secondary_DTs): Add documentation.
	(Validate_Position): Improve this static check in case of
	aliased subprograms because aliased subprograms must have
	the same position.
	(Init_Predefined_Interface_Primitives): New subprogram that initializes
	the entries associated with predefined primitives of all the secondary
	dispatch tables.
	(Build_Anonymous_Access_Type): Removed.
	(Expand_Interface_Actuals): With the previous cleanup there is no need
	to build an anonymous access type. This allows further cleanup in the
	code generated by the expander.
	(Expand_Interface_Conversion): If the actual is an access type then
	build an internal function to handle the displacement. If the actual
	is null this function 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.
	(Expand_Interface_Actuals): Avoid the generation of unnecessary type
	conversions that have no effect in the generated code because no
	displacement is required. Code cleanup; use local variables to
	avoid repeated calls to the subprogram directly_designated_type().

	* exp_util.ads, exp_util.adb (Is_Predefined_Dispatching_Operation):
	Classify the primitive operations used in dispatching selects as
	predefined.
	(Implements_Limited_Interface): Determine whether some type either
	directly implements a limited interface or extends a type that
	implements a limited interface.
	(Build_Task_Image_Function): Change Subtype_Mark to Result_Definition.
	(Expand_Subtype_From_Expr): Do not build actual subtype if the
	expression is limited.
	(Find_Interface_Tag): Add code to handle class-wide types and
	entities from the limited-view.

	* rtsfind.ads: Add entries in RE_Id and RE_Unit_Table for
	Get_Entry_Index, Get_Prim_Op_Kind, POK_Function, POK_Procedure,
	POK_Protected_Entry, POK_Protected_Function, POK_Protected_Procedure,
	POK_Task_Entry, POK_Task_Procedure, Prim_Op_Kind, Set_Entry_Index,
	Set_Prim_Op_Kind.

	* sem_ch9.adb (Analyze_Triggering_Alternative): Check for legal type
	of procedure name or prefix that appears as a trigger in a triggering
	alternative.

	* uintp.ads: Introduce constants Uint_11 and Uint_13.

From-SVN: r103850

gcc/ada/a-tags.adb

@@ -65,18 +65,35 @@ package body Ada.Tags is
 --                                          |      tags         |
 --                                          +-------------------+
 --                                          | table of          |
---                                          |   interface       |
+--                                          :   interface       :
 --                                          |      tags         |
 --                                          +-------------------+
+--                                          | table of          |
+--                                          :   primitive op    :
+--                                          |     kinds         |
+--                                          +-------------------+
+--                                          | table of          |
+--                                          :   entry           :
+--                                          |     indices       |
+--                                          +-------------------+
 
    subtype Cstring is String (Positive);
    type Cstring_Ptr is access all Cstring;
 
+   --  We suppress index checks because the declared size in the record below
+   --  is a dummy size of one (see below).
+
    type Tag_Table is array (Natural range <>) of Tag;
    pragma Suppress_Initialization (Tag_Table);
    pragma Suppress (Index_Check, On => Tag_Table);
-   --  We suppress index checks because the declared size in the record below
-   --  is a dummy size of one (see below).
+
+   type Prim_Op_Kind_Table is array (Natural range <>) of Prim_Op_Kind;
+   pragma Suppress_Initialization (Prim_Op_Kind_Table);
+   pragma Suppress (Index_Check, On => Prim_Op_Kind_Table);
+
+   type Entry_Index_Table is array (Natural range <>) of Positive;
+   pragma Suppress_Initialization (Entry_Index_Table);
+   pragma Suppress (Index_Check, On => Entry_Index_Table);
 
    type Type_Specific_Data is record
       Idepth : Natural;
@@ -121,6 +138,16 @@ package body Ada.Tags is
       --  purpose we are using the same mechanism as for the Prims_Ptr array in
       --  the Dispatch_Table record. See comments below on Prims_Ptr for
       --  further details.
+
+      POK_Table       : Prim_Op_Kind_Table (1 .. 1);
+      Ent_Index_Table : Entry_Index_Table  (1 .. 1);
+      --  Two auxiliary tables used for dispatching in asynchronous,
+      --  conditional and timed selects. Their size depends on the number
+      --  of primitive operations. Indexing in these two tables is performed
+      --  by subtracting the number of predefined primitive operations from
+      --  the given index value. POK_Table contains the callable entity kinds
+      --  of all non-predefined primitive operations. Ent_Index_Table contains
+      --  the entry index of primitive entry wrappers.
    end record;
 
    type Dispatch_Table is record
@@ -242,15 +269,12 @@ package body Ada.Tags is
          Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
          Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
          J    : Integer := 1;
-
       begin
          loop
             if Str1 (J) /= Str2 (J) then
                return False;
-
             elsif Str1 (J) = ASCII.NUL then
                return True;
-
             else
                J := J + 1;
             end if;
@@ -331,21 +355,26 @@ package body Ada.Tags is
 
    function IW_Membership
      (This : System.Address;
-      Iface_Tag : Tag) return Boolean
+      T    : Tag) return Boolean
    is
-      T        : constant Tag := To_Tag_Ptr (This).all;
-      Obj_Base : constant System.Address := This - Offset_To_Top (T);
-      T_Base   : constant Tag := To_Tag_Ptr (Obj_Base).all;
+      Curr_DT  : constant Tag := To_Tag_Ptr (This).all;
+      Obj_Base : constant System.Address := This - Offset_To_Top (Curr_DT);
+      Obj_DT   : constant Tag := To_Tag_Ptr (Obj_Base).all;
 
-      Obj_TSD  : constant Type_Specific_Data_Ptr := TSD (T_Base);
+      Obj_TSD : constant Type_Specific_Data_Ptr := TSD (Obj_DT);
       Last_Id : constant Natural := Obj_TSD.Idepth + Obj_TSD.Num_Interfaces;
       Id      : Natural;
 
    begin
       if Obj_TSD.Num_Interfaces > 0 then
-         Id := Obj_TSD.Idepth + 1;
+
+         --  Traverse the ancestor tags table plus the interface tags table.
+         --  The former part is required to give support to:
+         --     Iface_CW in Typ'Class
+
+         Id := 0;
          loop
-            if Obj_TSD.Tags_Table (Id) = Iface_Tag then
+            if Obj_TSD.Tags_Table (Id) = T then
                return True;
             end if;
 
@@ -413,6 +442,17 @@ package body Ada.Tags is
       return TSD (T).Access_Level;
    end Get_Access_Level;
 
+   ---------------------
+   -- Get_Entry_Index --
+   ---------------------
+
+   function Get_Entry_Index
+     (T        : Tag;
+      Position : Positive) return Positive is
+   begin
+      return TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count);
+   end Get_Entry_Index;
+
    ----------------------
    -- Get_External_Tag --
    ----------------------
@@ -433,6 +473,17 @@ package body Ada.Tags is
       return T.Prims_Ptr (Position);
    end Get_Prim_Op_Address;
 
+   ----------------------
+   -- Get_Prim_Op_Kind --
+   ----------------------
+
+   function Get_Prim_Op_Kind
+     (T        : Tag;
+      Position : Positive) return Prim_Op_Kind is
+   begin
+      return TSD (T).POK_Table (Position - Default_Prim_Op_Count);
+   end Get_Prim_Op_Kind;
+
    -------------------
    -- Get_RC_Offset --
    -------------------
@@ -485,8 +536,8 @@ package body Ada.Tags is
          --  of the parent
 
          New_TSD_Ptr.Tags_Table
-           (1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces)
-           := Old_TSD_Ptr.Tags_Table
+           (1 .. New_TSD_Ptr.Idepth + New_TSD_Ptr.Num_Interfaces) :=
+             Old_TSD_Ptr.Tags_Table
                (0 .. Old_TSD_Ptr.Idepth + Old_TSD_Ptr.Num_Interfaces);
       else
          New_TSD_Ptr.Idepth         := 0;
@@ -588,8 +639,8 @@ package body Ada.Tags is
       --  The tag of the parent type through the dispatch table
 
       F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
-      --  Access to the _size primitive of the parent. We assume that
-      --  it is always in the first slot of the dispatch table
+      --  Access to the _size primitive of the parent. We assume that it is
+      --  always in the first slot of the dispatch table
 
    begin
       --  Here we compute the size of the _parent field of the object
@@ -672,6 +723,18 @@ package body Ada.Tags is
       TSD (T).Access_Level := Value;
    end Set_Access_Level;
 
+   ---------------------
+   -- Set_Entry_Index --
+   ---------------------
+
+   procedure Set_Entry_Index
+     (T        : Tag;
+      Position : Positive;
+      Value    : Positive) is
+   begin
+      TSD (T).Ent_Index_Table (Position - Default_Prim_Op_Count) := Value;
+   end Set_Entry_Index;
+
    -----------------------
    -- Set_Expanded_Name --
    -----------------------
@@ -718,6 +781,18 @@ package body Ada.Tags is
       T.Prims_Ptr (Position) := Value;
    end Set_Prim_Op_Address;
 
+   ----------------------
+   -- Set_Prim_Op_Kind --
+   ----------------------
+
+   procedure Set_Prim_Op_Kind
+     (T        : Tag;
+      Position : Positive;
+      Value    : Prim_Op_Kind) is
+   begin
+      TSD (T).POK_Table (Position - Default_Prim_Op_Count) := Value;
+   end Set_Prim_Op_Kind;
+
    -------------------
    -- Set_RC_Offset --
    -------------------

gcc/ada/a-tags.ads

@@ -40,11 +40,8 @@ with System.Storage_Elements;
 with Unchecked_Conversion;
 
 package Ada.Tags is
-pragma Preelaborate_05 (Tags);
---  In accordance with Ada 2005 AI-362
-
-   pragma Elaborate_Body;
-   --  We need a dummy body to solve bootstrap path issues (why ???)
+   pragma Preelaborate_05;
+   --  In accordance with Ada 2005 AI-362
 
    type Tag is private;
 
@@ -101,6 +98,29 @@ private
    type Type_Specific_Data;
    type Type_Specific_Data_Ptr is access all Type_Specific_Data;
 
+   --  Primitive operation kinds. These values differentiate the kinds of
+   --  callable entities stored in the dispatch table. Certain kinds may
+   --  not be used, but are added for completeness.
+
+   type Prim_Op_Kind is
+     (POK_Function,
+      POK_Procedure,
+      POK_Protected_Entry,
+      POK_Protected_Function,
+      POK_Protected_Procedure,
+      POK_Task_Entry,
+      POK_Task_Procedure);
+
+   --  Number of predefined primitive operations added by the Expander
+   --  for a tagged type. It is utilized for indexing in the two auxiliary
+   --  tables used for dispatching asynchronous, conditional and timed
+   --  selects. In order to be space efficien, indexing is performed by
+   --  subtracting this constant value from the provided position in the
+   --  auxiliary tables.
+   --  This value is mirrored from Exp_Disp.ads.
+
+   Default_Prim_Op_Count : constant Positive := 14;
+
    package SSE renames System.Storage_Elements;
 
    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean;
@@ -109,14 +129,30 @@ private
 
    function IW_Membership
      (This : System.Address;
-      Iface_Tag : Tag) return Boolean;
-   --  Ada 2005 (AI-251): Given the tag of an object and the tag associated
-   --  with an interface, return true if Obj is in Iface'Class.
+      T    : Tag) return Boolean;
+   --  Ada 2005 (AI-251): General routine that checks if a given object
+   --  implements a tagged type. Its common usage is to check if Obj is in
+   --  Iface'Class, but it is also used to check if a class-wide interface
+   --  implements a given type (Iface_CW_Typ in T'Class). For example:
+   --
+   --      type I is interface;
+   --      type T is tagged ...
+   --
+   --      function Test (O : in I'Class) is
+   --      begin
+   --         return O in T'Class.
+   --      end Test;
 
    function Get_Access_Level (T : Tag) return Natural;
    --  Given the tag associated with a type, returns the accessibility level
    --  of the type.
 
+   function Get_Entry_Index
+     (T        : Tag;
+      Position : Positive) return Positive;
+   --  Return a primitive operation's entry index (if entry) given a dispatch
+   --  table T and a position of a primitive operation in T.
+
    function Get_External_Tag (T : Tag) return System.Address;
    --  Retrieve the address of a null terminated string containing
    --  the external name
@@ -124,10 +160,16 @@ private
    function Get_Prim_Op_Address
      (T        : Tag;
       Position : Positive) return System.Address;
-   --  Given a pointer to a dispatch Table (T) and a position in the DT
+   --  Given a pointer to a dispatch table (T) and a position in the DT
    --  this function returns the address of the virtual function stored
    --  in it (used for dispatching calls)
 
+   function Get_Prim_Op_Kind
+     (T        : Tag;
+      Position : Positive) return Prim_Op_Kind;
+   --  Return a primitive operation's kind given a dispatch table T and a
+   --  position of a primitive operation in T.
+
    function Get_RC_Offset (T : Tag) return SSE.Storage_Offset;
    --  Return the Offset of the implicit record controller when the object
    --  has controlled components. O otherwise.
@@ -173,6 +215,13 @@ private
    --  Insert the Tag and its associated external_tag in a table for the
    --  sake of Internal_Tag
 
+   procedure Set_Entry_Index
+     (T        : Tag;
+      Position : Positive;
+      Value    : Positive);
+   --  Set the entry index of a primitive operation in T's TSD table indexed
+   --  by Position.
+
    procedure Set_Offset_To_Top
      (T     : Tag;
       Value : System.Storage_Elements.Storage_Offset);
@@ -185,13 +234,20 @@ private
      (T        : Tag;
       Position : Positive;
       Value    : System.Address);
-   --  Given a pointer to a dispatch Table (T) and a position in the
-   --  dispatch Table put the address of the virtual function in it
-   --  (used for overriding)
+   --  Given a pointer to a dispatch Table (T) and a position in the dispatch
+   --  Table put the address of the virtual function in it (used for
+   --  overriding).
+
+   procedure Set_Prim_Op_Kind
+     (T        : Tag;
+      Position : Positive;
+      Value    : Prim_Op_Kind);
+   --  Set the kind of a primitive operation in T's TSD table indexed by
+   --  Position.
 
    procedure Set_TSD (T : Tag; Value : System.Address);
    --  Given a pointer T to a dispatch Table, stores the address of the record
-   --  containing the Type Specific Data generated by GNAT
+   --  containing the Type Specific Data generated by GNAT.
 
    procedure Set_Access_Level (T : Tag; Value : Natural);
    --  Sets the accessibility level of the tagged type associated with T
@@ -199,11 +255,11 @@ private
 
    procedure Set_Expanded_Name (T : Tag; Value : System.Address);
    --  Set the address of the string containing the expanded name
-   --  in the Dispatch table
+   --  in the Dispatch table.
 
    procedure Set_External_Tag (T : Tag; Value : System.Address);
    --  Set the address of the string containing the external tag
-   --  in the Dispatch table
+   --  in the Dispatch table.
 
    procedure Set_RC_Offset (T : Tag; Value : SSE.Storage_Offset);
    --  Sets the Offset of the implicit record controller when the object

gcc/ada/einfo.adb

@@ -215,9 +215,9 @@ package body Einfo is
 
    --    Abstract_Interface_Alias        Node25
 
-   --    (unused)                        Node26
+   --    Overridden_Operation            Node26
 
-   --    (unused)                        Node27
+   --    Wrapped_Entity                  Node27
 
    ---------------------------------------------
    -- Usage of Flags in Defining Entity Nodes --
@@ -442,9 +442,9 @@ package body Einfo is
    --    Has_Specified_Stream_Read      Flag192
    --    Has_Specified_Stream_Write     Flag193
    --    Is_Local_Anonymous_Access      Flag194
+   --    Is_Primitive_Wrapper           Flag195
+   --    Was_Hidden                     Flag196
 
-   --    (unused)                       Flag195
-   --    (unused)                       Flag196
    --    (unused)                       Flag197
    --    (unused)                       Flag198
    --    (unused)                       Flag199
@@ -512,8 +512,7 @@ package body Einfo is
 
    function Abstract_Interface_Alias (Id : E) return E is
    begin
-      pragma Assert
-        (Ekind (Id) = E_Procedure or Ekind (Id) = E_Function);
+      pragma Assert (Is_Subprogram (Id));
       return Node25 (Id);
    end Abstract_Interface_Alias;
 
@@ -1734,6 +1733,12 @@ package body Einfo is
       return Flag59 (Id);
    end Is_Preelaborated;
 
+   function Is_Primitive_Wrapper (Id : E) return B is
+   begin
+      pragma Assert (Ekind (Id) = E_Procedure);
+      return Flag195 (Id);
+   end Is_Primitive_Wrapper;
+
    function Is_Private_Composite (Id : E) return B is
    begin
       pragma Assert (Is_Type (Id));
@@ -2038,6 +2043,11 @@ package body Einfo is
       return Node22 (Id);
    end Original_Record_Component;
 
+   function Overridden_Operation (Id : E) return E is
+   begin
+      return Node26 (Id);
+   end Overridden_Operation;
+
    function Packed_Array_Type (Id : E) return E is
    begin
       pragma Assert (Is_Array_Type (Id));
@@ -2325,6 +2335,18 @@ package body Einfo is
       return Flag96 (Id);
    end Warnings_Off;
 
+   function Wrapped_Entity (Id : E) return E is
+   begin
+      pragma Assert (Ekind (Id) = E_Procedure
+                       and then Is_Primitive_Wrapper (Id));
+      return Node27 (Id);
+   end Wrapped_Entity;
+
+   function Was_Hidden (Id : E) return B is
+   begin
+      return Flag196 (Id);
+   end Was_Hidden;
+
    ------------------------------
    -- Classification Functions --
    ------------------------------
@@ -3799,6 +3821,12 @@ package body Einfo is
       Set_Flag59 (Id, V);
    end Set_Is_Preelaborated;
 
+   procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is
+   begin
+      pragma Assert (Ekind (Id) = E_Procedure);
+      Set_Flag195 (Id, V);
+   end Set_Is_Primitive_Wrapper;
+
    procedure Set_Is_Private_Composite (Id : E; V : B := True) is
    begin
       pragma Assert (Is_Type (Id));
@@ -4107,6 +4135,11 @@ package body Einfo is
       Set_Node22 (Id, V);
    end Set_Original_Record_Component;
 
+   procedure Set_Overridden_Operation (Id : E; V : E) is
+   begin
+      Set_Node26 (Id, V);
+   end Set_Overridden_Operation;
+
    procedure Set_Packed_Array_Type (Id : E; V : E) is
    begin
       pragma Assert (Is_Array_Type (Id));
@@ -4400,6 +4433,18 @@ package body Einfo is
       Set_Flag96 (Id, V);
    end Set_Warnings_Off;
 
+   procedure Set_Was_Hidden (Id : E; V : B := True) is
+   begin
+      Set_Flag196 (Id, V);
+   end Set_Was_Hidden;
+
+   procedure Set_Wrapped_Entity (Id : E; V : E) is
+   begin
+      pragma Assert (Ekind (Id) = E_Procedure
+                       and then Is_Primitive_Wrapper (Id));
+      Set_Node27 (Id, V);
+   end Set_Wrapped_Entity;
+
    -----------------------------------
    -- Field Initialization Routines --
    -----------------------------------
@@ -6328,6 +6373,15 @@ package body Einfo is
                return Underlying_Type (Full_View (Id));
             end if;
 
+         --  If we have an incomplete entity that comes from the limited
+         --  view then we return the Underlying_Type of its non-limited
+         --  view.
+
+         elsif From_With_Type (Id)
+           and then Present (Non_Limited_View (Id))
+         then
+            return Underlying_Type (Non_Limited_View (Id));
+
          --  Otherwise check for the case where we have a derived type or
          --  subtype, and if so get the Underlying_Type of the parent type.
 
@@ -6538,6 +6592,7 @@ package body Einfo is
       W ("Is_Packed_Array_Type",          Flag138 (Id));
       W ("Is_Potentially_Use_Visible",    Flag9   (Id));
       W ("Is_Preelaborated",              Flag59  (Id));
+      W ("Is_Primitive_Wrapper",          Flag195 (Id));
       W ("Is_Private_Composite",          Flag107 (Id));
       W ("Is_Private_Descendant",         Flag53  (Id));
       W ("Is_Public",                     Flag10  (Id));
@@ -6589,6 +6644,7 @@ package body Einfo is
       W ("Uses_Sec_Stack",                Flag95  (Id));
       W ("Vax_Float",                     Flag151 (Id));
       W ("Warnings_Off",                  Flag96  (Id));
+      W ("Was_Hidden",                    Flag196 (Id));
    end Write_Entity_Flags;
 
    -----------------------
@@ -7504,6 +7560,10 @@ package body Einfo is
    procedure Write_Field26_Name (Id : Entity_Id) is
    begin
       case Ekind (Id) is
+         when E_Procedure                                |
+              E_Function                                 =>
+            Write_Str ("Overridden_Operation");
+
          when others                                     =>
             Write_Str ("Field26??");
       end case;
@@ -7516,6 +7576,9 @@ package body Einfo is
    procedure Write_Field27_Name (Id : Entity_Id) is
    begin
       case Ekind (Id) is
+         when E_Procedure                                =>
+            Write_Str ("Wrapped_Entity");
+
          when others                                     =>
             Write_Str ("Field27??");
       end case;

gcc/ada/einfo.ads

@@ -183,7 +183,7 @@ package Einfo is
 --       dynamic bounds, it is assumed that the value can range down or up
 --       to the corresponding bound of the ancestor
 
---    The RM defined attribute Size corresponds to the Value_Size attribute.
+--    The RM defined attribute Size corresponds to the Value_Size attribute
 
 --    The Size attribute may be defined for a first-named subtype. This sets
 --    the Value_Size of the first-named subtype to the given value, and the
@@ -2243,6 +2243,11 @@ package Einfo is
 --       flag is set does not necesarily mean that no elaboration code is
 --       generated for the package.
 
+--    Is_Primitive_Wrapper (Flag195)
+--       Present in E_Procedures. Primitive wrappers are Expander-generated
+--       procedures that wrap entries of protected or task types implementing
+--       a limited interface.
+
 --    Is_Private_Composite (Flag107)
 --       Present in composite types that have a private component. Used to
 --       enforce the rule that operations on the composite type that depend
@@ -2769,6 +2774,10 @@ package Einfo is
 --       In subtypes (tagged and untagged):
 --         Points to the component in the base type.
 
+--    Overridden_Operation (Node26)
+--       Present in subprograms. For overriding operations, points to the
+--       user-defined parent subprogram that is being overridden.
+
 --    Packed_Array_Type (Node23)
 --       Present in array types and subtypes, including the string literal
 --       subtype case, if the corresponding type is packed (either bit packed
@@ -3220,6 +3229,14 @@ package Einfo is
 --       is used to suppress warnings for a given entity. It is also used by
 --       the compiler in some situations to kill spurious warnings.
 
+--    Was_Hidden (Flag196)
+--       Present in all entities. Used to save the value of the Is_Hidden
+--       attribute when the limited-view is installed (Ada 2005: AI-217).
+
+--    Wrapped_Entity (Node27)
+--       Present in an E_Procedure classified as a Is_Primitive_Wrapper. Set
+--       to the entity that is being wrapped.
+
    ------------------
    -- Access Kinds --
    ------------------
@@ -3488,7 +3505,7 @@ package Einfo is
       --  A record type, created by a record type declaration
 
       E_Record_Subtype,
-      --  A record subtype, created by a record subtype declaration.
+      --  A record subtype, created by a record subtype declaration
 
       E_Record_Type_With_Private,
       --  Used for types defined by a private extension declaration, and
@@ -3499,7 +3516,7 @@ package Einfo is
       --  a private type.
 
       E_Record_Subtype_With_Private,
-      --  A subtype of a type defined by a private extension declaration.
+      --  A subtype of a type defined by a private extension declaration
 
       E_Private_Type,
       --  A private type, created by a private type declaration
@@ -4033,6 +4050,7 @@ package Einfo is
    --    Is_Packed_Array_Type          (Flag138)
    --    Is_Potentially_Use_Visible    (Flag9)
    --    Is_Preelaborated              (Flag59)
+   --    Is_Primitive_Wrapper          (Flag195)
    --    Is_Public                     (Flag10)
    --    Is_Pure                       (Flag44)
    --    Is_Remote_Call_Interface      (Flag62)
@@ -4050,6 +4068,7 @@ package Einfo is
    --    Referenced_As_LHS             (Flag36)
    --    Suppress_Elaboration_Warnings (Flag148)
    --    Suppress_Style_Checks         (Flag165)
+   --    Was_Hidden                    (Flag196)
 
    --    Declaration_Node              (synth)
    --    Enclosing_Dynamic_Scope       (synth)
@@ -4401,6 +4420,7 @@ package Einfo is
    --    Privals_Chain                 (Elist23)  (for a protected function)
    --    Obsolescent_Warning           (Node24)
    --    Abstract_Interface_Alias      (Node25)
+   --    Overridden_Operation          (Node26)
    --    Body_Needed_For_SAL           (Flag40)
    --    Elaboration_Entity_Required   (Flag174)
    --    Function_Returns_With_DSP     (Flag169)
@@ -4648,6 +4668,9 @@ package Einfo is
    --    Privals_Chain                 (Elist23)  (for a protected procedure)
    --    Obsolescent_Warning           (Node24)
    --    Abstract_Interface_Alias      (Node25)
+   --    Overridden_Operation          (Node26)
+   --    Wrapped_Entity                (Node27)   (non-generic case only)
+
    --    Body_Needed_For_SAL           (Flag40)
    --    Elaboration_Entity_Required   (Flag174)
    --    Function_Returns_With_DSP     (Flag169)  (always False for procedure)
@@ -4673,6 +4696,8 @@ package Einfo is
    --    Is_Machine_Code_Subprogram    (Flag137)  (non-generic case only)
    --    Is_Null_Init_Proc             (Flag178)
    --    Is_Overriding_Operation       (Flag39)   (non-generic case only)
+   --    Is_Primitive_Wrapper          (Flag195)  (non-generic case only)
+
    --    Is_Private_Descendant         (Flag53)
    --    Is_Pure                       (Flag44)
    --    Is_Thread_Body                (Flag77)   (non-generic case only)
@@ -5299,6 +5324,8 @@ package Einfo is
    function Is_Packed_Array_Type               (Id : E) return B;
    function Is_Potentially_Use_Visible         (Id : E) return B;
    function Is_Preelaborated                   (Id : E) return B;
+   function Is_Primitive_Wrapper               (Id : E) return B;
+
    function Is_Private_Composite               (Id : E) return B;
    function Is_Private_Descendant              (Id : E) return B;
    function Is_Public                          (Id : E) return B;
@@ -5351,6 +5378,7 @@ package Einfo is
    function Original_Access_Type               (Id : E) return E;
    function Original_Array_Type                (Id : E) return E;
    function Original_Record_Component          (Id : E) return E;
+   function Overridden_Operation               (Id : E) return E;
    function Packed_Array_Type                  (Id : E) return E;
    function Parent_Subtype                     (Id : E) return E;
    function Primitive_Operations               (Id : E) return L;
@@ -5402,6 +5430,8 @@ package Einfo is
    function Uses_Sec_Stack                     (Id : E) return B;
    function Vax_Float                          (Id : E) return B;
    function Warnings_Off                       (Id : E) return B;
+   function Was_Hidden                         (Id : E) return B;
+   function Wrapped_Entity                     (Id : E) return E;
 
    -------------------------------
    -- Classification Attributes --
@@ -5792,6 +5822,8 @@ package Einfo is
    procedure Set_Is_Packed_Array_Type          (Id : E; V : B := True);
    procedure Set_Is_Potentially_Use_Visible    (Id : E; V : B := True);
    procedure Set_Is_Preelaborated              (Id : E; V : B := True);
+   procedure Set_Is_Primitive_Wrapper          (Id : E; V : B := True);
+
    procedure Set_Is_Private_Composite          (Id : E; V : B := True);
    procedure Set_Is_Private_Descendant         (Id : E; V : B := True);
    procedure Set_Is_Public                     (Id : E; V : B := True);
@@ -5843,6 +5875,7 @@ package Einfo is
    procedure Set_Original_Access_Type          (Id : E; V : E);
    procedure Set_Original_Array_Type           (Id : E; V : E);
    procedure Set_Original_Record_Component     (Id : E; V : E);
+   procedure Set_Overridden_Operation          (Id : E; V : E);
    procedure Set_Packed_Array_Type             (Id : E; V : E);
    procedure Set_Parent_Subtype                (Id : E; V : E);
    procedure Set_Primitive_Operations          (Id : E; V : L);
@@ -5894,6 +5927,8 @@ package Einfo is
    procedure Set_Uses_Sec_Stack                (Id : E; V : B := True);
    procedure Set_Vax_Float                     (Id : E; V : B := True);
    procedure Set_Warnings_Off                  (Id : E; V : B := True);
+   procedure Set_Was_Hidden                    (Id : E; V : B := True);
+   procedure Set_Wrapped_Entity                (Id : E; V : E);
 
    -----------------------------------
    -- Field Initialization Routines --
@@ -6360,6 +6395,8 @@ package Einfo is
    pragma Inline (Is_Packed_Array_Type);
    pragma Inline (Is_Potentially_Use_Visible);
    pragma Inline (Is_Preelaborated);
+   pragma Inline (Is_Primitive_Wrapper);
+
    pragma Inline (Is_Private_Composite);
    pragma Inline (Is_Private_Descendant);
    pragma Inline (Is_Private_Type);
@@ -6421,6 +6458,7 @@ package Einfo is
    pragma Inline (Original_Access_Type);
    pragma Inline (Original_Array_Type);
    pragma Inline (Original_Record_Component);
+   pragma Inline (Overridden_Operation);
    pragma Inline (Packed_Array_Type);
    pragma Inline (Parameter_Mode);
    pragma Inline (Parent_Subtype);
@@ -6473,6 +6511,8 @@ package Einfo is
    pragma Inline (Uses_Sec_Stack);
    pragma Inline (Vax_Float);
    pragma Inline (Warnings_Off);
+   pragma Inline (Was_Hidden);
+   pragma Inline (Wrapped_Entity);
 
    pragma Inline (Init_Alignment);
    pragma Inline (Init_Component_Bit_Offset);
@@ -6692,6 +6732,8 @@ package Einfo is
    pragma Inline (Set_Is_Packed_Array_Type);
    pragma Inline (Set_Is_Potentially_Use_Visible);
    pragma Inline (Set_Is_Preelaborated);
+   pragma Inline (Set_Is_Primitive_Wrapper);
+
    pragma Inline (Set_Is_Private_Composite);
    pragma Inline (Set_Is_Private_Descendant);
    pragma Inline (Set_Is_Public);
@@ -6743,6 +6785,7 @@ package Einfo is
    pragma Inline (Set_Original_Access_Type);
    pragma Inline (Set_Original_Array_Type);
    pragma Inline (Set_Original_Record_Component);
+   pragma Inline (Set_Overridden_Operation);
    pragma Inline (Set_Packed_Array_Type);
    pragma Inline (Set_Parent_Subtype);
    pragma Inline (Set_Primitive_Operations);
@@ -6794,6 +6837,8 @@ package Einfo is
    pragma Inline (Set_Uses_Sec_Stack);
    pragma Inline (Set_Vax_Float);
    pragma Inline (Set_Warnings_Off);
+   pragma Inline (Set_Was_Hidden);
+   pragma Inline (Set_Wrapped_Entity);
 
    --  END XEINFO INLINES
 

gcc/ada/exp_ch3.adb

@@ -27,7 +27,6 @@
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
-with Elists;   use Elists;
 with Errout;   use Errout;
 with Exp_Aggr; use Exp_Aggr;
 with Exp_Ch4;  use Exp_Ch4;
@@ -867,7 +866,7 @@ package body Exp_Ch3 is
          Parameter_List := Build_Discriminant_Formals (Rec_Id, False);
 
          Set_Parameter_Specifications (Spec_Node, Parameter_List);
-         Set_Subtype_Mark (Spec_Node,
+         Set_Result_Definition (Spec_Node,
                                 New_Reference_To (Standard_Boolean,  Loc));
          Set_Specification (Body_Node, Spec_Node);
          Set_Declarations (Body_Node, New_List);
@@ -1482,16 +1481,21 @@ package body Exp_Ch3 is
                 Attribute_Name => Name_Unrestricted_Access);
          end if;
 
-         --  Ada 2005 (AI-231): Generate conversion to the null-excluding
-         --  type to force the corresponding run-time check.
+         --  Ada 2005 (AI-231): Add the run-time check if required
 
          if Ada_Version >= Ada_05
            and then Can_Never_Be_Null (Etype (Id))            -- Lhs
-           and then Present (Etype (Exp))
+         then
+            if Nkind (Exp) = N_Null then
+               return New_List (
+                 Make_Raise_Constraint_Error (Sloc (Exp),
+                   Reason => CE_Null_Not_Allowed));
+
+            elsif Present (Etype (Exp))
               and then not Can_Never_Be_Null (Etype (Exp))
             then
-            Rewrite (Exp, Convert_To (Etype (Id), Relocate_Node (Exp)));
-            Analyze_And_Resolve (Exp, Etype (Id));
+               Install_Null_Excluding_Check (Exp);
+            end if;
          end if;
 
          --  Take a copy of Exp to ensure that later copies of this
@@ -3017,7 +3021,7 @@ package body Exp_Ch3 is
             Make_Function_Specification (Loc,
               Defining_Unit_Name       => F,
               Parameter_Specifications => Pspecs,
-              Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
+              Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
           Declarations               => New_List,
           Handled_Statement_Sequence =>
             Make_Handled_Sequence_Of_Statements (Loc,
@@ -3698,19 +3702,6 @@ package body Exp_Ch3 is
 
             elsif Is_Access_Type (Typ) then
 
-               --  Ada 2005 (AI-231): Generate conversion to the null-excluding
-               --  type to force the corresponding run-time check
-
-               if Ada_Version >= Ada_05
-                 and then (Can_Never_Be_Null (Def_Id)
-                             or else Can_Never_Be_Null (Typ))
-               then
-                  Rewrite
-                    (Expr_Q,
-                     Convert_To (Etype (Def_Id), Relocate_Node (Expr_Q)));
-                  Analyze_And_Resolve (Expr_Q, Etype (Def_Id));
-               end if;
-
                --  For access types set the Is_Known_Non_Null flag if the
                --  initializing value is known to be non-null. We can also set
                --  Can_Never_Be_Null if this is a constant.
@@ -4362,7 +4353,7 @@ package body Exp_Ch3 is
                     Make_Defining_Identifier (Loc, Name_uF),
                   Parameter_Type => New_Reference_To (Standard_Boolean, Loc))),
 
-              Subtype_Mark => New_Reference_To (Standard_Integer, Loc)),
+              Result_Definition => New_Reference_To (Standard_Integer, Loc)),
 
             Declarations => Empty_List,
 
@@ -4392,10 +4383,10 @@ package body Exp_Ch3 is
    ------------------------
 
    procedure Freeze_Record_Type (N : Node_Id) is
-      Def_Id      : constant Node_Id := Entity (N);
       Comp        : Entity_Id;
-      Type_Decl   : constant Node_Id := Parent (Def_Id);
+      Def_Id      : constant Node_Id := Entity (N);
       Predef_List : List_Id;
+      Type_Decl   : constant Node_Id := Parent (Def_Id);
 
       Renamed_Eq  : Node_Id := Empty;
       --  Could use some comments ???
@@ -4534,6 +4525,7 @@ package body Exp_Ch3 is
             Make_Predefined_Primitive_Specs
               (Def_Id, Predef_List, Renamed_Eq);
             Insert_List_Before_And_Analyze (N, Predef_List);
+
             Set_Is_Frozen (Def_Id, True);
             Set_All_DT_Position (Def_Id);
 
@@ -4623,6 +4615,8 @@ package body Exp_Ch3 is
 
             Append_Freeze_Actions
               (Def_Id, Predefined_Primitive_Freeze (Def_Id));
+            Append_Freeze_Actions
+              (Def_Id, Init_Predefined_Interface_Primitives (Def_Id));
          end if;
 
       --  In the non-tagged case, an equality function is provided only for
@@ -4696,8 +4690,20 @@ package body Exp_Ch3 is
       if Is_Tagged_Type (Def_Id) then
          Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
          Append_Freeze_Actions (Def_Id, Predef_List);
-      end if;
 
+         --  Populate the two auxiliary tables used for dispatching
+         --  asynchronous, conditional and timed selects for tagged
+         --  types that implement a limited interface.
+
+         if Ada_Version >= Ada_05
+           and then not Is_Interface  (Def_Id)
+           and then not Is_Abstract   (Def_Id)
+           and then not Is_Controlled (Def_Id)
+           and then Implements_Limited_Interface (Def_Id)
+         then
+            Append_Freeze_Actions (Def_Id, Make_Disp_Select_Tables (Def_Id));
+         end if;
+      end if;
    end Freeze_Record_Type;
 
    ------------------------------
@@ -5887,6 +5893,67 @@ package body Exp_Ch3 is
                Parameter_Type      => New_Reference_To (Tag_Typ, Loc)))));
       end if;
 
+      --  Generate the declarations for the following primitive operations:
+      --    disp_asynchronous_select
+      --    disp_conditional_select
+      --    disp_get_prim_op_kind
+      --    disp_timed_select
+      --  for limited interfaces and tagged types that implement a limited
+      --  interface.
+
+      if Ada_Version >= Ada_05
+        and then
+            ((Is_Interface (Tag_Typ)
+                and then Is_Limited_Record (Tag_Typ))
+          or else
+             (not Is_Abstract (Tag_Typ)
+                and then not Is_Controlled (Tag_Typ)
+                and then Implements_Limited_Interface (Tag_Typ)))
+      then
+         if Is_Interface (Tag_Typ) then
+            Append_To (Res,
+              Make_Abstract_Subprogram_Declaration (Loc,
+                Specification =>
+                  Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
+
+            Append_To (Res,
+              Make_Abstract_Subprogram_Declaration (Loc,
+                Specification =>
+                  Make_Disp_Conditional_Select_Spec (Tag_Typ)));
+
+            Append_To (Res,
+              Make_Abstract_Subprogram_Declaration (Loc,
+                Specification =>
+                  Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
+
+            Append_To (Res,
+              Make_Abstract_Subprogram_Declaration (Loc,
+                Specification =>
+                  Make_Disp_Timed_Select_Spec (Tag_Typ)));
+
+         else
+            Append_To (Res,
+              Make_Subprogram_Declaration (Loc,
+                Specification =>
+                  Make_Disp_Asynchronous_Select_Spec (Tag_Typ)));
+
+            Append_To (Res,
+              Make_Subprogram_Declaration (Loc,
+                Specification =>
+                  Make_Disp_Conditional_Select_Spec (Tag_Typ)));
+
+            Append_To (Res,
+              Make_Subprogram_Declaration (Loc,
+                Specification =>
+                  Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ)));
+
+            Append_To (Res,
+              Make_Subprogram_Declaration (Loc,
+                Specification =>
+                  Make_Disp_Timed_Select_Spec (Tag_Typ)));
+         end if;
+      end if;
+
       --  Specs for finalization actions that may be required in case a
       --  future extension contain a controlled element. We generate those
       --  only for root tagged types where they will get dummy bodies or
@@ -6059,7 +6126,7 @@ package body Exp_Ch3 is
            Make_Function_Specification (Loc,
              Defining_Unit_Name       => Id,
              Parameter_Specifications => Profile,
-             Subtype_Mark             =>
+             Result_Definition        =>
                New_Reference_To (Ret_Type, Loc));
       end if;
 
@@ -6242,6 +6309,29 @@ package body Exp_Ch3 is
          end if;
       end if;
 
+      --  Generate the bodies for the following primitive operations:
+      --    disp_asynchronous_select
+      --    disp_conditional_select
+      --    disp_get_prim_op_kind
+      --    disp_timed_select
+      --  for tagged types that implement a limited interface.
+
+      if Ada_Version >= Ada_05
+        and then not Is_Interface  (Tag_Typ)
+        and then not Is_Abstract   (Tag_Typ)
+        and then not Is_Controlled (Tag_Typ)
+        and then Implements_Limited_Interface (Tag_Typ)
+      then
+         Append_To (Res,
+           Make_Disp_Asynchronous_Select_Body (Tag_Typ));
+         Append_To (Res,
+           Make_Disp_Conditional_Select_Body  (Tag_Typ));
+         Append_To (Res,
+           Make_Disp_Get_Prim_Op_Kind_Body    (Tag_Typ));
+         Append_To (Res,
+           Make_Disp_Timed_Select_Body        (Tag_Typ));
+      end if;
+
       if not Is_Limited_Type (Tag_Typ) then
 
          --  Body for equality

gcc/ada/exp_ch7.adb

@@ -1560,19 +1560,6 @@ package body Exp_Ch7 is
       end if;
 
       Set_Elaboration_Flag (N, Corresponding_Spec (N));
-
-      --  Generate a subprogram descriptor for the elaboration routine of
-      --  a package body if the package body has no pending instantiations
-      --  and it has generated at least one exception handler
-
-      if Present (Handler_Records (Body_Entity (Ent)))
-        and then Is_Compilation_Unit (Ent)
-        and then not Delay_Subprogram_Descriptors (Body_Entity (Ent))
-      then
-         Generate_Subprogram_Descriptor_For_Package
-           (N, Body_Entity (Ent));
-      end if;
-
       Set_In_Package_Body (Ent, False);
 
       --  Set to encode entity names in package body before gigi is called
@@ -2220,6 +2207,8 @@ package body Exp_Ch7 is
               or else Has_Interrupt_Handler (Pid)
               or else (Has_Attach_Handler (Pid)
                          and then not Restricted_Profile)
+              or else (Ada_Version >= Ada_05
+                         and then Present (Interface_List (Parent (Pid))))
             then
                if Abort_Allowed
                  or else Restriction_Active (No_Entry_Queue) = False

gcc/ada/exp_ch9.adb

@@ -57,11 +57,261 @@ with Snames;   use Snames;
 with Stand;    use Stand;
 with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
-with Types;    use Types;
 with Uintp;    use Uintp;
 
 package body Exp_Ch9 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
+      function Build_Abort_Block
+        (Loc     : Source_Ptr;
+         Blk_Ent : Entity_Id;
+         Blk     : Node_Id) return Node_Id;
+      --  Generate:
+      --    begin
+      --       Blk
+      --    exception
+      --       when Abort_Signal => Abort_Undefer;
+      --    end;
+      --  Blk_Ent is the name of the encapsulated block, Blk is the actual
+      --  block node.
+
+      function Build_B
+        (Loc   : Source_Ptr;
+         Decls : List_Id) return Entity_Id;
+      --  Generate:
+      --    B : Boolean := False;
+      --  Append the object declaration to the list and return the name of
+      --  the object.
+
+      function Build_C
+        (Loc   : Source_Ptr;
+         Decls : List_Id) return Entity_Id;
+      --  Generate:
+      --    C : Ada.Tags.Prim_Op_Kind;
+      --  Append the object declaration to the list and return the name of
+      --  the object.
+
+      function Build_Cleanup_Block
+        (Loc       : Source_Ptr;
+         Blk_Ent   : Entity_Id;
+         Stmts     : List_Id;
+         Clean_Ent : Entity_Id) return Node_Id;
+      --  Generate:
+      --    declare
+      --       procedure _clean is
+      --       begin
+      --          ...
+      --       end _clean;
+      --    begin
+      --       Stmts
+      --    at end
+      --       _clean;
+      --    end;
+      --  Blk_Ent is the name of the generated block, Stmts is the list
+      --  of encapsulated statements and Clean_Ent is the parameter to
+      --  the _clean procedure.
+
+      function Build_S
+        (Loc      : Source_Ptr;
+         Decls    : List_Id;
+         Call_Ent : Entity_Id) return Entity_Id;
+      --  Generate:
+      --    S : constant Integer := DT_Position (Call_Ent);
+      --  where Call_Ent is the entity of the dispatching call name. Append
+      --  the object declaration to the list and return the name of the
+      --  object.
+
+      function Build_Wrapping_Procedure
+        (Loc   : Source_Ptr;
+         Nam   : Character;
+         Decls : List_Id;
+         Stmts : List_Id) return Entity_Id;
+      --  Generate:
+      --    procedure <temp>Nam is
+      --    begin
+      --       Stmts
+      --    end <temp>Nam;
+      --  where Nam is the generated procedure name and Stmts are the
+      --  encapsulated statements. Append the procedure body to Decls.
+      --  Return the internally generated procedure name.
+   end Select_Expansion_Utilities;
+
+   package body Select_Expansion_Utilities is
+
+      -----------------------
+      -- Build_Abort_Block --
+      -----------------------
+
+      function Build_Abort_Block
+        (Loc   : Source_Ptr;
+         Blk_Ent : Entity_Id;
+         Blk     : Node_Id) return Node_Id
+      is
+      begin
+         return
+           Make_Block_Statement (Loc,
+             Declarations =>
+               No_List,
+
+             Handled_Statement_Sequence =>
+               Make_Handled_Sequence_Of_Statements (Loc,
+                 Statements =>
+                   New_List (
+                     Make_Implicit_Label_Declaration (Loc,
+                       Defining_Identifier =>
+                         Blk_Ent,
+                       Label_Construct =>
+                         Blk),
+                     Blk),
+
+                 Exception_Handlers =>
+                   New_List (
+                     Make_Exception_Handler (Loc,
+                       Exception_Choices =>
+                         New_List (
+                           New_Reference_To (Stand.Abort_Signal, Loc)),
+                       Statements =>
+                         New_List (
+                           Make_Procedure_Call_Statement (Loc,
+                             Name =>
+                               New_Reference_To (RTE (
+                                 RE_Abort_Undefer), Loc),
+                             Parameter_Associations => No_List))))));
+      end Build_Abort_Block;
+
+      -------------
+      -- Build_B --
+      -------------
+
+      function Build_B
+        (Loc   : Source_Ptr;
+         Decls : List_Id) return Entity_Id
+      is
+         B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
+
+      begin
+         Append_To (Decls,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier =>
+               B,
+             Object_Definition =>
+               New_Reference_To (Standard_Boolean, Loc),
+             Expression =>
+               New_Reference_To (Standard_False, Loc)));
+
+         return B;
+      end Build_B;
+
+      -------------
+      -- Build_C --
+      -------------
+
+      function Build_C
+        (Loc   : Source_Ptr;
+         Decls : List_Id) return Entity_Id
+      is
+         C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
+
+      begin
+         Append_To (Decls,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier =>
+               C,
+             Object_Definition =>
+               New_Reference_To (RTE (RE_Prim_Op_Kind), Loc)));
+
+         return C;
+      end Build_C;
+
+      -------------------------
+      -- Build_Cleanup_Block --
+      -------------------------
+
+      function Build_Cleanup_Block
+        (Loc       : Source_Ptr;
+         Blk_Ent   : Entity_Id;
+         Stmts     : List_Id;
+         Clean_Ent : Entity_Id) return Node_Id
+      is
+         Cleanup_Block : constant Node_Id :=
+                           Make_Block_Statement (Loc,
+                             Identifier   => New_Reference_To (Blk_Ent, Loc),
+                             Declarations => No_List,
+                             Handled_Statement_Sequence =>
+                               Make_Handled_Sequence_Of_Statements (Loc,
+                                 Statements => Stmts),
+                             Is_Asynchronous_Call_Block => True);
+
+      begin
+         Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);
+
+         return Cleanup_Block;
+      end Build_Cleanup_Block;
+
+      -------------
+      -- Build_S --
+      -------------
+
+      function Build_S
+        (Loc      : Source_Ptr;
+         Decls    : List_Id;
+         Call_Ent : Entity_Id) return Entity_Id
+      is
+         S : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uS);
+
+      begin
+         Append_To (Decls,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => S,
+             Constant_Present    => True,
+             Object_Definition   =>
+               New_Reference_To (Standard_Integer, Loc),
+             Expression          =>
+               Make_Integer_Literal (Loc,
+                 Intval => DT_Position (Call_Ent))));
+
+         return S;
+      end Build_S;
+
+      ------------------------------
+      -- Build_Wrapping_Procedure --
+      ------------------------------
+
+      function Build_Wrapping_Procedure
+        (Loc   : Source_Ptr;
+         Nam   : Character;
+         Decls : List_Id;
+         Stmts : List_Id) return Entity_Id
+      is
+         Proc_Nam : constant Entity_Id :=
+                      Make_Defining_Identifier (Loc, New_Internal_Name (Nam));
+      begin
+         Append_To (Decls,
+           Make_Subprogram_Body (Loc,
+             Specification =>
+               Make_Procedure_Specification (Loc,
+                 Defining_Unit_Name =>
+                   Proc_Nam),
+             Declarations =>
+               No_List,
+             Handled_Statement_Sequence =>
+               Make_Handled_Sequence_Of_Statements (Loc,
+                 Statements =>
+                   New_Copy_List (Stmts))));
+
+         return Proc_Nam;
+      end Build_Wrapping_Procedure;
+   end Select_Expansion_Utilities;
+
+   package SEU renames Select_Expansion_Utilities;
+
    -----------------------
    -- Local Subprograms --
    -----------------------
@@ -76,17 +326,6 @@ package body Exp_Ch9 is
    --  the expression computed by this function uses the discriminants
    --  of the target task.
 
-   function Index_Constant_Declaration
-     (N        : Node_Id;
-      Index_Id : Entity_Id;
-      Prot     : Entity_Id) return List_Id;
-   --  For an entry family and its barrier function, we define a local entity
-   --  that maps the index in the call into the entry index into the object:
-   --
-   --     I : constant Index_Type := Index_Type'Val (
-   --       E - <<index of first family member>> +
-   --       Protected_Entry_Index (Index_Type'Pos (Index_Type'First)));
-
    procedure Add_Object_Pointer
      (Decls : List_Id;
       Pid   : Entity_Id;
@@ -131,6 +370,23 @@ package body Exp_Ch9 is
    --  of the range of each entry family. A single array with that size is
    --  allocated for each concurrent object of the type.
 
+   function Build_Parameter_Block
+     (Loc     : Source_Ptr;
+      Actuals : List_Id;
+      Formals : List_Id;
+      Decls   : List_Id) return Entity_Id;
+   --  Generate an access type for each actual parameter in the list Actuals.
+   --  Cleate an encapsulating record that contains all the actuals and return
+   --  its type. Generate:
+   --    type Ann1 is access all <actual1-type>
+   --    ...
+   --    type AnnN is access all <actualN-type>
+   --    type Pnn is record
+   --       <formal1> : Ann1;
+   --       ...
+   --       <formalN> : AnnN;
+   --    end record;
+
    function Build_Wrapper_Body
      (Loc      : Source_Ptr;
       Proc_Nam : Entity_Id;
@@ -272,6 +528,16 @@ package body Exp_Ch9 is
    --  to the use of 'Length on the index type, but must use Family_Offset
    --  to handle properly the case of bounds that depend on discriminants.
 
+   procedure Extract_Dispatching_Call
+     (N        : Node_Id;
+      Call_Ent : out Entity_Id;
+      Object   : out Entity_Id;
+      Actuals  : out List_Id;
+      Formals  : out List_Id);
+   --  Given a dispatching call, extract the entity of the name of the call,
+   --  its object parameter, its actual parameters and the formal parameters
+   --  of the overriden interface-level version.
+
    procedure Extract_Entry
      (N       : Node_Id;
       Concval : out Node_Id;
@@ -289,6 +555,47 @@ package body Exp_Ch9 is
    --  when P is Name_uPriority, the call will also find Interrupt_Priority.
    --  ??? Should be implemented with the rep item chain mechanism.
 
+   function Index_Constant_Declaration
+     (N        : Node_Id;
+      Index_Id : Entity_Id;
+      Prot     : Entity_Id) return List_Id;
+   --  For an entry family and its barrier function, we define a local entity
+   --  that maps the index in the call into the entry index into the object:
+   --
+   --     I : constant Index_Type := Index_Type'Val (
+   --       E - <<index of first family member>> +
+   --       Protected_Entry_Index (Index_Type'Pos (Index_Type'First)));
+
+   function Parameter_Block_Pack
+     (Loc     : Source_Ptr;
+      Blk_Typ : Entity_Id;
+      Actuals : List_Id;
+      Formals : List_Id;
+      Decls   : List_Id;
+      Stmts   : List_Id) return Node_Id;
+   --  Set the components of the generated parameter block with the values of
+   --  the actual parameters. Generate aliased temporaries to capture the
+   --  values for types that are passed by copy. Otherwise generate a reference
+   --  to the actual's value. Return the address of the aggregate block.
+   --  Generate:
+   --    Jnn1 : alias <formal-type1>;
+   --    Jnn1 := <actual1>;
+   --    ...
+   --    P : Blk_Typ := (
+   --      Jnn1'unchecked_access;
+   --      <actual2>'reference;
+   --      ...);
+
+   function Parameter_Block_Unpack
+     (Loc     : Source_Ptr;
+      Actuals : List_Id;
+      Formals : List_Id) return List_Id;
+   --  Retrieve the values of the components from the parameter block and
+   --  assign then to the original actual parameters. Generate:
+   --    <actual1> := P.<formal1>;
+   --    ...
+   --    <actualN> := P.<formalN>;
+
    procedure Update_Prival_Subtypes (N : Node_Id);
    --  The actual subtypes of the privals will differ from the type of the
    --  private declaration in the original protected type, if the protected
@@ -579,7 +886,13 @@ package body Exp_Ch9 is
          elsif Has_Interrupt_Handler (Typ) then
             Protection_Type := RE_Dynamic_Interrupt_Protection;
 
-         elsif Has_Entries (Typ) then
+         --  The type has explicit entries or generated primitive entry
+         --  wrappers.
+
+         elsif Has_Entries (Typ)
+            or else (Ada_Version >= Ada_05
+                       and then Present (Interface_List (Parent (Typ))))
+         then
             if Abort_Allowed
               or else Restriction_Active (No_Entry_Queue) = False
               or else Number_Entries (Typ) > 1
@@ -836,7 +1149,7 @@ package body Exp_Ch9 is
             Parameter_Type =>
               New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
 
-        Subtype_Mark => New_Reference_To (Standard_Boolean, Loc));
+        Result_Definition => New_Reference_To (Standard_Boolean, Loc));
    end Build_Barrier_Function_Specification;
 
    --------------------------
@@ -998,9 +1311,92 @@ package body Exp_Ch9 is
       return Ecount;
    end Build_Entry_Count_Expression;
 
-   ------------------------------
+   ---------------------------
+   -- Build_Parameter_Block --
+   ---------------------------
+
+   function Build_Parameter_Block
+     (Loc     : Source_Ptr;
+      Actuals : List_Id;
+      Formals : List_Id;
+      Decls   : List_Id) return Entity_Id
+   is
+      Actual   : Entity_Id;
+      Comp_Nam : Node_Id;
+      Comp_Rec : Node_Id;
+      Comps    : List_Id;
+      Formal   : Entity_Id;
+
+   begin
+      Actual := First (Actuals);
+      Comps  := New_List;
+      Formal := Defining_Identifier (First (Formals));
+      while Present (Actual) loop
+         --  Generate:
+         --    type Ann is access all <actual-type>
+
+         Comp_Nam :=
+           Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+
+         Append_To (Decls,
+           Make_Full_Type_Declaration (Loc,
+             Defining_Identifier =>
+               Comp_Nam,
+             Type_Definition =>
+               Make_Access_To_Object_Definition (Loc,
+                 All_Present =>
+                   True,
+                 Constant_Present =>
+                   Ekind (Formal) = E_In_Parameter,
+                 Subtype_Indication =>
+                   New_Reference_To (Etype (Actual), Loc))));
+
+         --  Generate:
+         --    Param : Ann;
+
+         Append_To (Comps,
+           Make_Component_Declaration (Loc,
+             Defining_Identifier =>
+               Make_Defining_Identifier (Loc, Chars (Formal)),
+             Component_Definition =>
+               Make_Component_Definition (Loc,
+                 Aliased_Present =>
+                   False,
+                 Subtype_Indication =>
+                   New_Reference_To (Comp_Nam, Loc))));
+
+         Next_Actual (Actual);
+         Next_Formal_With_Extras (Formal);
+      end loop;
+
+      --  Generate:
+      --    type Pnn is record
+      --       Param1 : Ann1;
+      --       ...
+      --       ParamN : AnnN;
+
+      --  where Pnn is a parameter wrapping record, Param1 .. ParamN are the
+      --  original parameter names and Ann1 .. AnnN are the access to actual
+      --  types.
+
+      Comp_Rec :=
+        Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+
+      Append_To (Decls,
+        Make_Full_Type_Declaration (Loc,
+          Defining_Identifier =>
+            Comp_Rec,
+          Type_Definition =>
+            Make_Record_Definition (Loc,
+              Component_List =>
+                Make_Component_List (Loc, Comps))));
+
+      return Comp_Rec;
+   end Build_Parameter_Block;
+
+   ------------------------
    -- Build_Wrapper_Body --
-   ------------------------------
+   ------------------------
 
    function Build_Wrapper_Body
      (Loc      : Source_Ptr;
@@ -1371,6 +1767,9 @@ package body Exp_Ch9 is
         or else Ekind (Proc_Nam) = E_Entry
       then
          Set_Ekind                (New_Name_Id, E_Procedure);
+         Set_Is_Primitive_Wrapper (New_Name_Id);
+         Set_Wrapped_Entity       (New_Name_Id, Proc_Nam);
+
          return
            Make_Procedure_Specification (Loc,
              Defining_Unit_Name => New_Name_Id,
@@ -1378,11 +1777,13 @@ package body Exp_Ch9 is
 
       else pragma Assert (Ekind (Proc_Nam) = E_Function);
          Set_Ekind (New_Name_Id, E_Function);
+
          return
            Make_Function_Specification (Loc,
              Defining_Unit_Name => New_Name_Id,
              Parameter_Specifications => New_Formals,
-             Subtype_Mark => New_Copy (Subtype_Mark (Parent (Proc_Nam))));
+             Result_Definition =>
+               New_Copy (Result_Definition (Parent (Proc_Nam))));
       end if;
    end Build_Wrapper_Spec;
 
@@ -1602,7 +2003,7 @@ package body Exp_Ch9 is
               Defining_Identifier => Parm2,
               Parameter_Type =>
                 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
-          Subtype_Mark => New_Occurrence_Of (
+          Result_Definition => New_Occurrence_Of (
             RTE (RE_Protected_Entry_Index), Loc));
    end Build_Find_Body_Index_Spec;
 
@@ -1897,7 +2298,7 @@ package body Exp_Ch9 is
    function Build_Protected_Sub_Specification
      (N       : Node_Id;
       Prottyp : Entity_Id;
-      Unprotected : Boolean := False) return Node_Id
+      Mode    : Subprogram_Protection_Mode) return Node_Id
    is
       Loc       : constant Source_Ptr := Sloc (N);
       Decl      : Node_Id;
@@ -1906,9 +2307,13 @@ package body Exp_Ch9 is
       Nam       : Name_Id;
       New_Id    : Entity_Id;
       New_Plist : List_Id;
-      Append_Char : Character;
       New_Spec  : Node_Id;
 
+      Append_Chr : constant array (Subprogram_Protection_Mode) of Character :=
+                     (Dispatching_Mode => ' ',
+                      Protected_Mode   => 'P',
+                      Unprotected_Mode => 'N');
+
    begin
       if Ekind
          (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body
@@ -1921,26 +2326,14 @@ package body Exp_Ch9 is
       Ident := Defining_Unit_Name (Specification (Decl));
       Nam := Chars (Ident);
 
-      New_Plist := Build_Protected_Spec
-                        (Decl, Corresponding_Record_Type (Prottyp),
-                         Unprotected, Ident);
-
-      if Unprotected then
-         Append_Char := 'N';
-      else
-         --  Ada 2005 (AI-345): The protected version no longer uses 'P'
-         --  as suffix in order to make it a primitive operation
-
-         if Ada_Version >= Ada_05 then
-            Append_Char := ' ';
-         else
-            Append_Char := 'P';
-         end if;
-      end if;
+      New_Plist :=
+        Build_Protected_Spec (Decl,
+          Corresponding_Record_Type (Prottyp),
+                              Mode = Unprotected_Mode, Ident);
 
       New_Id :=
         Make_Defining_Identifier (Loc,
-          Chars => Build_Selected_Name (Protnm, Nam, Append_Char));
+          Chars => Build_Selected_Name (Protnm, Nam, Append_Chr (Mode)));
 
       --  The unprotected operation carries the user code, and debugging
       --  information must be generated for it, even though this spec does
@@ -1961,7 +2354,8 @@ package body Exp_Ch9 is
            Make_Function_Specification (Loc,
              Defining_Unit_Name => New_Id,
              Parameter_Specifications => New_Plist,
-             Subtype_Mark => New_Copy (Subtype_Mark (Specification (Decl))));
+             Result_Definition =>
+               New_Copy (Result_Definition (Specification (Decl))));
          Set_Return_Present (Defining_Unit_Name (New_Spec));
          return New_Spec;
       end if;
@@ -2089,8 +2483,7 @@ package body Exp_Ch9 is
       Exc_Safe := Is_Exception_Safe (N);
 
       P_Op_Spec :=
-        Build_Protected_Sub_Specification (N,
-          Pid, Unprotected => False);
+        Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
 
       --  Build a list of the formal parameters of the protected
       --  version of the subprogram to use as the actual parameters
@@ -2116,7 +2509,7 @@ package body Exp_Ch9 is
               Make_Object_Declaration (Loc,
                 Defining_Identifier => R,
                 Constant_Present => True,
-                Object_Definition => New_Copy (Subtype_Mark (N_Op_Spec)),
+                Object_Definition => New_Copy (Result_Definition (N_Op_Spec)),
                 Expression =>
                   Make_Function_Call (Loc,
                     Name => Make_Identifier (Loc,
@@ -2162,7 +2555,10 @@ package body Exp_Ch9 is
 
       if Has_Entries (Pid)
         or else Has_Interrupt_Handler (Pid)
-        or else (Has_Attach_Handler (Pid) and then not Restricted_Profile)
+        or else (Has_Attach_Handler (Pid)
+                  and then not Restricted_Profile)
+        or else (Ada_Version >= Ada_05
+                  and then Present (Interface_List (Parent (Pid))))
       then
          if Abort_Allowed
            or else Restriction_Active (No_Entry_Queue) = False
@@ -3004,8 +3400,7 @@ package body Exp_Ch9 is
 
       Op_Decls := Declarations (N);
       N_Op_Spec :=
-        Build_Protected_Sub_Specification
-          (N, Pid, Unprotected => True);
+        Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode);
 
       return
         Make_Subprogram_Body (Loc,
@@ -3687,7 +4082,8 @@ package body Exp_Ch9 is
          Def1 :=
            Make_Access_Function_Definition (Loc,
              Parameter_Specifications => P_List,
-             Subtype_Mark => New_Copy (Subtype_Mark (Type_Definition (N))));
+             Result_Definition =>
+               New_Copy (Result_Definition (Type_Definition (N))));
 
       else
          Def1 :=
@@ -4158,9 +4554,10 @@ package body Exp_Ch9 is
    -- Expand_N_Asynchronous_Select --
    ----------------------------------
 
-   --  This procedure assumes that the trigger statement is an entry call. A
-   --  delay alternative should already have been expanded into an entry call
-   --  to the appropriate delay object Wait entry.
+   --  This procedure assumes that the trigger statement is an entry call or
+   --  a dispatching procedure call. A delay alternative should already have
+   --  been expanded into an entry call to the appropriate delay object Wait
+   --  entry.
 
    --  If the trigger is a task entry call, the select is implemented with
    --  a Task_Entry_Call:
@@ -4191,19 +4588,19 @@ package body Exp_Ch9 is
    --       begin
    --          begin
    --             Abort_Undefer;
-   --             abortable-part
+   --             <abortable-part>
    --          at end
    --             _clean;        --  Added by Exp_Ch7.Expand_Cleanup_Actions.
    --          end;
-
    --       exception
    --          when Abort_Signal => Abort_Undefer;
    --       end;
+
    --       parm := P.param;
    --       parm := P.param;
    --       ...
    --       if not C then
-   --          triggered-statements
+   --          <triggered-statements>
    --       end if;
    --    end;
 
@@ -4250,20 +4647,17 @@ package body Exp_Ch9 is
    --             Mode => Asynchronous_Call;
    --             Block => Bnn);
    --           if Enqueued (Bnn) then
-   --              <abortable part>
+   --              <abortable-part>
    --           end if;
    --        at end
    --           _clean;        --  Added by Exp_Ch7.Expand_Cleanup_Actions.
    --        end;
-
    --     exception
-   --        when Abort_Signal =>
-   --           Abort_Undefer;
-   --           null;
+   --        when Abort_Signal => Abort_Undefer;
    --     end;
 
    --     if not Cancelled (Bnn) then
-   --        triggered statements
+   --        <triggered-statements>
    --     end if;
    --  end;
 
@@ -4286,52 +4680,164 @@ package body Exp_Ch9 is
    --       ...
    --  end;
 
-   --  The job is to convert this to the asynchronous form
+   --  Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
+   --  expanded into:
 
-   --  If the trigger is a delay statement, it will have been expanded into a
-   --  call to one of the GNARL delay procedures. This routine will convert
-   --  this into a protected entry call on a delay object and then continue
-   --  processing as for a protected entry call trigger. This requires
-   --  declaring a Delay_Block object and adding a pointer to this object to
-   --  the parameter list of the delay procedure to form the parameter list of
-   --  the entry call. This object is used by the runtime to queue the delay
-   --  request.
+   --  declare
+   --     B   : Boolean := False;
+   --     Bnn : Communication_Block;
+   --     C   : Ada.Tags.Prim_Op_Kind;
+   --     P   : Parameters := (Param1 .. ParamN)
+   --     S   : constant Integer := DT_Position (<dispatching-call>);
+   --     U   : Boolean;
+
+   --     procedure <temp>A is
+   --     begin
+   --        <abortable-statements>
+   --     end <temp>A;
 
-   --  For a description of the use of P and the assignments after the
-   --  call, see Expand_N_Entry_Call_Statement.
+   --     procedure <temp>T is
+   --     begin
+   --        <triggered-statements>
+   --     end <temp>T;
+
+   --  begin
+   --     disp_get_prim_op_kind (<object>, S, C);
+
+   --     if C = POK_Protected_Entry then
+   --        declare
+   --           procedure _clean is
+   --           begin
+   --              if Enqueued (Bnn) then
+   --                 Cancel_Protected_Entry_Call (Bnn);
+   --              end if;
+   --           end _clean;
+
+   --        begin
+   --           begin
+   --              disp_asynchronous_select
+   --                (Obj, S, P'address, Bnn, B);
+
+   --              Param1 := P.Param1;
+   --              ...
+   --              ParamN := P.ParamN;
+
+   --              if Enqueued (Bnn) then
+   --                 <temp>A;
+   --              end if;
+   --           at end
+   --              _clean;
+   --           end;
+   --        exception
+   --           when Abort_Signal => Abort_Undefer;
+   --        end;
+
+   --        if not Cancelled (Bnn) then
+   --           <temp>T;
+   --        end if;
+
+   --     elsif C = POK_Task_Entry then
+   --        declare
+   --           procedure _clean is
+   --           begin
+   --              Cancel_Task_Entry_Call (U);
+   --           end _clean;
+
+   --        begin
+   --           Abort_Defer;
+
+   --           disp_asynchronous_select
+   --             (<object>, S, P'address, Bnn, B);
+
+   --           Param1 := P.Param1;
+   --           ...
+   --           ParamN := P.ParamN;
+
+   --           begin
+   --              begin
+   --                 Abort_Undefer;
+   --                 <temp>A;
+   --              at end
+   --                 _clean;
+   --              end;
+   --           exception
+   --              when Abort_Signal => Abort_Undefer;
+   --           end;
+
+   --           if not U then
+   --              <temp>T;
+   --           end if;
+   --        end;
+
+   --     else
+   --        <dispatching-call>;
+   --        <temp>T;
+   --     end if;
+
+   --  The job is to convert this to the asynchronous form
+
+   --  If the trigger is a delay statement, it will have been expanded into a
+   --  call to one of the GNARL delay procedures. This routine will convert
+   --  this into a protected entry call on a delay object and then continue
+   --  processing as for a protected entry call trigger. This requires
+   --  declaring a Delay_Block object and adding a pointer to this object to
+   --  the parameter list of the delay procedure to form the parameter list of
+   --  the entry call. This object is used by the runtime to queue the delay
+   --  request.
+
+   --  For a description of the use of P and the assignments after the
+   --  call, see Expand_N_Entry_Call_Statement.
 
    procedure Expand_N_Asynchronous_Select (N : Node_Id) is
       Loc    : constant Source_Ptr := Sloc (N);
-      Trig   : constant Node_Id    := Triggering_Alternative (N);
       Abrt   : constant Node_Id    := Abortable_Part (N);
-      Tstats : constant List_Id    := Statements (Trig);
       Astats : constant List_Id    := Statements (Abrt);
+      Trig   : constant Node_Id    := Triggering_Alternative (N);
+      Tstats : constant List_Id    := Statements (Trig);
 
-      Ecall           : Node_Id;
+      Abortable_Block : Node_Id;
+      Actuals         : List_Id;
+      Aproc           : Entity_Id;
+      Blk_Ent         : Entity_Id;
+      Blk_Typ         : Entity_Id;
+      Call            : Node_Id;
+      Call_Ent        : Entity_Id;
+      Cancel_Param    : Entity_Id;
+      Cleanup_Block   : Node_Id;
+      Cleanup_Stmts   : List_Id;
       Concval         : Node_Id;
-      Ename           : Node_Id;
-      Index           : Node_Id;
-      Hdle            : List_Id;
-      Decls           : List_Id;
+      Dblock_Ent      : Entity_Id;
       Decl            : Node_Id;
-      Parms           : List_Id;
-      Parm            : Node_Id;
-      Call            : Node_Id;
-      Stmts           : List_Id;
+      Decls           : List_Id;
+      Ecall           : Node_Id;
+      Ename           : Node_Id;
       Enqueue_Call    : Node_Id;
-      Stmt            : Node_Id;
-      B               : Entity_Id;
-      Pdef            : Entity_Id;
-      Dblock_Ent      : Entity_Id;
+      Formals         : List_Id;
+      Hdle            : List_Id;
+      Index           : Node_Id;
       N_Orig          : Node_Id;
-      Abortable_Block : Node_Id;
-      Cancel_Param    : Entity_Id;
-      Blkent          : Entity_Id;
+      Obj             : Entity_Id;
+      Param           : Node_Id;
+      Params          : List_Id;
+      Pdef            : Entity_Id;
+      ProtE_Stmts     : List_Id;
+      ProtP_Stmts     : List_Id;
+      Stmt            : Node_Id;
+      Stmts           : List_Id;
       Target_Undefer  : RE_Id;
+      TaskE_Stmts     : List_Id;
+      Tproc           : Entity_Id;
       Undefer_Args    : List_Id := No_List;
 
+      B   : Entity_Id;  --  Call status flag
+      Bnn : Entity_Id;  --  Communication block
+      C   : Entity_Id;  --  Call kind
+      P   : Node_Id;    --  Parameter block
+      S   : Entity_Id;  --  Primitive operation slot
+      U   : Entity_Id;  --  Additional status flag
+
    begin
-      Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+      Blk_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
       Ecall   := Triggering_Statement (Trig);
 
       --  The arguments in the call may require dynamic allocation, and the
@@ -4341,7 +4847,6 @@ package body Exp_Ch9 is
 
       if Nkind (Ecall) = N_Block_Statement then
          Ecall := First (Statements (Handled_Statement_Sequence (Ecall)));
-
          while Nkind (Ecall) /= N_Procedure_Call_Statement
            and then Nkind (Ecall) /= N_Entry_Call_Statement
          loop
@@ -4349,27 +4854,398 @@ package body Exp_Ch9 is
          end loop;
       end if;
 
-      --  If a delay was used as a trigger, it will have been expanded
-      --  into a procedure call. Convert it to the appropriate sequence of
-      --  statements, similar to what is done for a task entry call.
-      --  Note that this currently supports only Duration, Real_Time.Time,
-      --  and Calendar.Time.
+      --  This is either a dispatching call or a delay statement used as a
+      --  trigger which was expanded into a procedure call.
+
+      if Nkind (Ecall) = N_Procedure_Call_Statement then
+         if Ada_Version >= Ada_05
+           and then
+             (not Present (Original_Node (Ecall))
+                or else
+              Nkind (Original_Node (Ecall)) /= N_Delay_Relative_Statement)
+         then
+            Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals);
+
+            Decls := New_List;
+            Stmts := New_List;
+
+            --  Call status flag processing, generate:
+            --    B : Boolean := False;
+
+            B := SEU.Build_B (Loc, Decls);
+
+            --  Communication block processing, generate:
+            --    Bnn : Communication_Block;
+
+            Bnn := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
+
+            Append_To (Decls,
+              Make_Object_Declaration (Loc,
+                Defining_Identifier =>
+                  Bnn,
+                Object_Definition =>
+                  New_Reference_To (RTE (RE_Communication_Block), Loc)));
+
+            --  Call kind processing, generate:
+            --    C : Ada.Tags.Prim_Op_Kind;
+
+            C := SEU.Build_C (Loc, Decls);
+
+            --  Parameter block processing
+
+            Blk_Typ := Build_Parameter_Block
+                         (Loc, Actuals, Formals, Decls);
+            P       := Parameter_Block_Pack
+                         (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
+
+            --  Dispatch table slot processing, generate:
+            --    S : constant Integer :=
+            --          DT_Position (<dispatching-procedure>);
+
+            S := SEU.Build_S (Loc, Decls, Call_Ent);
+
+            --  Additional status flag processing, generate:
+
+            U := Make_Defining_Identifier (Loc, Name_uU);
+
+            Append_To (Decls,
+              Make_Object_Declaration (Loc,
+                Defining_Identifier =>
+                  U,
+                Object_Definition =>
+                  New_Reference_To (Standard_Boolean, Loc)));
+
+            --  Generate:
+            --    procedure <temp>A is
+            --    begin
+            --       Astmts
+            --    end <temp>A;
+
+            Aproc := SEU.Build_Wrapping_Procedure (Loc, 'A', Decls, Astats);
+
+            --  Generate:
+            --    procedure <temp>T is
+            --    begin
+            --       Tstmts
+            --    end <temp>T;
+
+            Tproc := SEU.Build_Wrapping_Procedure (Loc, 'T', Decls, Tstats);
+
+            --  Generate:
+            --    _dispatching_get_prim_op_kind (<object>, S, C);
+
+            Append_To (Stmts,
+              Make_Procedure_Call_Statement (Loc,
+                Name =>
+                  Make_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind),
+                Parameter_Associations =>
+                  New_List (
+                    New_Copy_Tree    (Obj),
+                    New_Reference_To (S, Loc),
+                    New_Reference_To (C, Loc))));
+
+            --  Protected entry handling
+
+            --  Generate:
+            --    Param1 := P.Param1;
+            --    ...
+            --    ParamN := P.ParamN;
+
+            Cleanup_Stmts := Parameter_Block_Unpack (Loc, Actuals, Formals);
+
+            --  Generate:
+            --    _dispatching_asynchronous_select
+            --      (<object>, S, P'address, Bnn, B);
+
+            Prepend_To (Cleanup_Stmts,
+              Make_Procedure_Call_Statement (Loc,
+                Name =>
+                  Make_Identifier (Loc, Name_uDisp_Asynchronous_Select),
+                Parameter_Associations =>
+                  New_List (
+                    New_Copy_Tree    (Obj),
+                    New_Reference_To (S, Loc),
+                    P,
+                    New_Reference_To (Bnn, Loc),
+                    New_Reference_To (B, Loc))));
+
+            --  Generate:
+            --    if Enqueued (Bnn) then
+            --       <temp>A
+            --    end if;
+
+            --  where <temp>A is the abort statements wrapping procedure
+
+            Append_To (Cleanup_Stmts,
+              Make_If_Statement (Loc,
+                Condition =>
+                  Make_Function_Call (Loc,
+                    Name =>
+                      New_Reference_To (RTE (RE_Enqueued), Loc),
+                    Parameter_Associations =>
+                      New_List (
+                        New_Reference_To (Bnn, Loc))),
+
+                Then_Statements =>
+                  New_List (
+                    Make_Procedure_Call_Statement (Loc,
+                      Name =>
+                        New_Reference_To (Aproc, Loc),
+                      Parameter_Associations =>
+                        No_List))));
+
+            --  Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
+            --  will then generate a _clean for the communication block Bnn.
+
+            --  Generate:
+            --    declare
+            --       procedure _clean is
+            --       begin
+            --          if Enqueued (Bnn) then
+            --             Cancel_Protected_Entry_Call (Bnn);
+            --          end if;
+            --       end _clean;
+            --    begin
+            --       Cleanup_Stmts
+            --    at end
+            --       _clean;
+            --    end;
+
+            Cleanup_Block :=
+              SEU.Build_Cleanup_Block (Loc, Blk_Ent, Cleanup_Stmts, Bnn);
+
+            --  Wrap the cleanup block in an exception handling block.
+
+            --  Generate:
+            --    begin
+            --       Cleanup_Block
+            --    exception
+            --       when Abort_Signal => Abort_Undefer;
+            --    end;
+
+            ProtE_Stmts :=
+              New_List (
+                SEU.Build_Abort_Block (Loc, Blk_Ent, Cleanup_Block));
+
+            --  Generate:
+            --    if not Cancelled (Bnn) then
+            --       <temp>T
+            --    end if;
+
+            --  there <temp>T is the triggering statements wrapping procedure
+
+            Append_To (ProtE_Stmts,
+              Make_If_Statement (Loc,
+                Condition =>
+                  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 (Bnn, Loc)))),
+
+                Then_Statements =>
+                  New_List (
+                    Make_Procedure_Call_Statement (Loc,
+                      Name =>
+                        New_Reference_To (Tproc, Loc),
+                      Parameter_Associations =>
+                        No_List))));
+
+            -------------------------------------------------------------------
+            --  Task entry handling
+
+            --  Generate:
+            --    Param1 := P.Param1;
+            --    ...
+            --    ParamN := P.ParamN;
+
+            TaskE_Stmts := Parameter_Block_Unpack (Loc, Actuals, Formals);
+
+            --  Generate:
+            --    _dispatching_asynchronous_select
+            --      (<object>, S, P'address, Bnn, B);
+
+            Prepend_To (TaskE_Stmts,
+              Make_Procedure_Call_Statement (Loc,
+                Name =>
+                  Make_Identifier (Loc, Name_uDisp_Asynchronous_Select),
+                Parameter_Associations =>
+                  New_List (
+                    New_Copy_Tree    (Obj),
+                    New_Reference_To (S, Loc),
+                    New_Copy_Tree    (P),
+                    New_Reference_To (Bnn, Loc),
+                    New_Reference_To (B, Loc))));
+
+            --  Generate:
+            --    Abort_Defer;
+
+            Prepend_To (TaskE_Stmts,
+              Make_Procedure_Call_Statement (Loc,
+                Name =>
+                  New_Reference_To (RTE (RE_Abort_Defer), Loc),
+                Parameter_Associations =>
+                  No_List));
+
+            --  Generate:
+            --    Abort_Undefer;
+            --    <temp>A
+
+            --  where <temp>A is the abortable statements wrapping procedure
+
+            Cleanup_Stmts :=
+              New_List (
+                Make_Procedure_Call_Statement (Loc,
+                  Name =>
+                    New_Reference_To (RTE (RE_Abort_Undefer), Loc),
+                  Parameter_Associations =>
+                    No_List),
+
+                Make_Procedure_Call_Statement (Loc,
+                  Name =>
+                    New_Reference_To (Aproc, Loc),
+                  Parameter_Associations =>
+                    No_List));
+
+            --  Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
+            --  will generate a _clean for the additional status flag.
+
+            --  Generate:
+            --    declare
+            --       procedure _clean is
+            --       begin
+            --          Cancel_Task_Entry_Call (U);
+            --       end _clean;
+            --    begin
+            --       Cleanup_Stmts
+            --    at end
+            --       _clean;
+            --    end;
+
+            Blk_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+
+            Cleanup_Block :=
+              SEU.Build_Cleanup_Block (Loc, Blk_Ent, Cleanup_Stmts, U);
+
+            --  Wrap the cleanup block in an exception handling block
+
+            --  Generate:
+            --    begin
+            --       Cleanup_Block
+            --    exception
+            --       when Abort_Signal => Abort_Undefer;
+            --    end;
+
+            Append_To (TaskE_Stmts,
+              SEU.Build_Abort_Block (Loc, Blk_Ent, Cleanup_Block));
+
+            --  Generate:
+            --    if not U then
+            --       <temp>T
+            --    end if;
+
+            --  where <temp>T is the triggering statements wrapping procedure
+
+            Append_To (TaskE_Stmts,
+              Make_If_Statement (Loc,
+                Condition =>
+                  Make_Op_Not (Loc,
+                    Right_Opnd =>
+                      New_Reference_To (U, Loc)),
+                Then_Statements =>
+                  New_List (
+                    Make_Procedure_Call_Statement (Loc,
+                      Name =>
+                        New_Reference_To (Tproc, Loc),
+                      Parameter_Associations =>
+                        No_List))));
+
+            -------------------------------------------------------------------
+            --  Protected procedure handling
+
+            --  Generate:
+            --    <dispatching-call>;
+            --    <temp>T;
+
+            --  where <temp>T is the triggering statements wrapping procedure
+
+            ProtP_Stmts :=
+              New_List (
+                New_Copy_Tree (Ecall),
+
+                Make_Procedure_Call_Statement (Loc,
+                  Name =>
+                    New_Reference_To (Tproc, Loc),
+                  Parameter_Associations =>
+                    No_List));
+
+            --  Generate:
+            --    if C = POK_Procedure_Entry then
+            --       ProtE_Stmts
+            --    elsif C = POK_Task_Entry then
+            --       TaskE_Stmts
+            --    else
+            --       ProtP_Stmts
+            --    end if;
+
+            Append_To (Stmts,
+              Make_If_Statement (Loc,
+                Condition =>
+                  Make_Op_Eq (Loc,
+                    Left_Opnd =>
+                      New_Reference_To (C, Loc),
+                    Right_Opnd =>
+                      New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)),
+
+                Then_Statements =>
+                  ProtE_Stmts,
+
+                Elsif_Parts =>
+                  New_List (
+                    Make_Elsif_Part (Loc,
+                      Condition =>
+                        Make_Op_Eq (Loc,
+                          Left_Opnd =>
+                            New_Reference_To (C, Loc),
+                          Right_Opnd =>
+                            New_Reference_To (RTE (RE_POK_Task_Entry), Loc)),
+                      Then_Statements =>
+                        TaskE_Stmts)),
+
+                Else_Statements =>
+                  ProtP_Stmts));
+
+            Rewrite (N,
+              Make_Block_Statement (Loc,
+                Declarations =>
+                  Decls,
+                Handled_Statement_Sequence =>
+                  Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
 
-      if Nkind (Ecall) = N_Procedure_Call_Statement then
+            Analyze (N);
+            return;
+
+         --  Delay triggering statement processing
 
-         --  Add a Delay_Block object to the parameter list of the
-         --  delay procedure to form the parameter list of the Wait
-         --  entry call.
+         else
+            --  Add a Delay_Block object to the parameter list of the delay
+            --  procedure to form the parameter list of the Wait entry call.
 
-         Dblock_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
+            Dblock_Ent :=
+              Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
 
             Pdef := Entity (Name (Ecall));
 
             if Is_RTE (Pdef, RO_CA_Delay_For) then
-            Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Duration), Loc);
+               Enqueue_Call :=
+                 New_Reference_To (RTE (RE_Enqueue_Duration), Loc);
 
             elsif Is_RTE (Pdef, RO_CA_Delay_Until) then
-            Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Calendar), Loc);
+               Enqueue_Call :=
+                 New_Reference_To (RTE (RE_Enqueue_Calendar), Loc);
 
             else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until));
                Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc);
@@ -4396,7 +5272,7 @@ package body Exp_Ch9 is
 
             Abortable_Block :=
               Make_Block_Statement (Loc,
-             Identifier => New_Reference_To (Blkent, Loc),
+                Identifier => New_Reference_To (Blk_Ent, Loc),
                 Handled_Statement_Sequence =>
                   Make_Handled_Sequence_Of_Statements (Loc,
                     Statements => Astats),
@@ -4416,7 +5292,7 @@ package body Exp_Ch9 is
                       Make_Handled_Sequence_Of_Statements (Loc,
                         Statements => New_List (
                           Make_Implicit_Label_Declaration (Loc,
-                         Defining_Identifier => Blkent,
+                            Defining_Identifier => Blk_Ent,
                             Label_Construct     => Abortable_Block),
                           Abortable_Block),
                         Exception_Handlers => Hdle)))));
@@ -4438,7 +5314,7 @@ package body Exp_Ch9 is
 
             --  The result is the new block
 
-         Set_Entry_Cancel_Parameter (Blkent, Dblock_Ent);
+            Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent);
 
             Rewrite (N,
               Make_Block_Statement (Loc,
@@ -4454,7 +5330,7 @@ package body Exp_Ch9 is
 
             Analyze (N);
             return;
-
+         end if;
       else
          N_Orig := N;
       end if;
@@ -4471,9 +5347,10 @@ package body Exp_Ch9 is
 
          Decl := First (Decls);
          while Present (Decl)
-           and then (Nkind (Decl) /= N_Object_Declaration
-             or else not Is_RTE
-               (Etype (Object_Definition (Decl)), RE_Communication_Block))
+           and then
+             (Nkind (Decl) /= N_Object_Declaration
+               or else not Is_RTE (Etype (Object_Definition (Decl)),
+                                   RE_Communication_Block))
          loop
             Next (Decl);
          end loop;
@@ -4481,7 +5358,8 @@ package body Exp_Ch9 is
          pragma Assert (Present (Decl));
          Cancel_Param := Defining_Identifier (Decl);
 
-         --  Change the mode of the Protected_Entry_Call call.
+         --  Change the mode of the Protected_Entry_Call call
+
          --  Protected_Entry_Call (
          --    Object => po._object'Access,
          --    E => <entry index>;
@@ -4491,7 +5369,8 @@ package body Exp_Ch9 is
 
          Stmt := First (Stmts);
 
-         --  Skip assignments to temporaries created for in-out parameters.
+         --  Skip assignments to temporaries created for in-out parameters
+
          --  This makes unwarranted assumptions about the shape of the expanded
          --  tree for the call, and should be cleaned up ???
 
@@ -4501,18 +5380,20 @@ package body Exp_Ch9 is
 
          Call := Stmt;
 
-         Parm := First (Parameter_Associations (Call));
-         while Present (Parm)
-           and then not Is_RTE (Etype (Parm), RE_Call_Modes)
+         Param := First (Parameter_Associations (Call));
+         while Present (Param)
+           and then not Is_RTE (Etype (Param), RE_Call_Modes)
          loop
-            Next (Parm);
+            Next (Param);
          end loop;
 
-         pragma Assert (Present (Parm));
-         Rewrite (Parm, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
-         Analyze (Parm);
+         pragma Assert (Present (Param));
+         Rewrite (Param, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
+         Analyze (Param);
+
+         --  Append an if statement to execute the abortable part
 
-         --  Append an if statement to execute the abortable part.
+         --  Generate:
          --    if Enqueued (Bnn) then
 
          Append_To (Stmts,
@@ -4526,7 +5407,7 @@ package body Exp_Ch9 is
 
          Abortable_Block :=
            Make_Block_Statement (Loc,
-             Identifier => New_Reference_To (Blkent, Loc),
+             Identifier => New_Reference_To (Blk_Ent, Loc),
              Handled_Statement_Sequence =>
                Make_Handled_Sequence_Of_Statements (Loc,
                  Statements => Stmts),
@@ -4552,7 +5433,7 @@ package body Exp_Ch9 is
                Make_Handled_Sequence_Of_Statements (Loc,
                  Statements => New_List (
                    Make_Implicit_Label_Declaration (Loc,
-                     Defining_Identifier => Blkent,
+                     Defining_Identifier => Blk_Ent,
                      Label_Construct     => Abortable_Block),
                    Abortable_Block),
 
@@ -4640,7 +5521,7 @@ package body Exp_Ch9 is
 
          Abortable_Block :=
            Make_Block_Statement (Loc,
-             Identifier => New_Reference_To (Blkent, Loc),
+             Identifier => New_Reference_To (Blk_Ent, Loc),
              Handled_Statement_Sequence =>
                Make_Handled_Sequence_Of_Statements (Loc,
                  Statements => Astats),
@@ -4653,26 +5534,32 @@ package body Exp_Ch9 is
                Make_Handled_Sequence_Of_Statements (Loc,
                  Statements => New_List (
                    Make_Implicit_Label_Declaration (Loc,
-                     Defining_Identifier => Blkent,
+                     Defining_Identifier => Blk_Ent,
                      Label_Construct     => Abortable_Block),
                    Abortable_Block),
                  Exception_Handlers => Hdle)));
 
          --  Create new call statement
 
-         Parms := Parameter_Associations (Call);
-         Append_To (Parms, New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
-         Append_To (Parms, New_Reference_To (B, Loc));
+         Params := Parameter_Associations (Call);
+
+         Append_To (Params,
+           New_Reference_To (RTE (RE_Asynchronous_Call), Loc));
+         Append_To (Params,
+           New_Reference_To (B, Loc));
+
          Rewrite (Call,
            Make_Procedure_Call_Statement (Loc,
-             Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
-             Parameter_Associations => Parms));
+             Name =>
+               New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
+             Parameter_Associations => Params));
 
          --  Construct statement sequence for new block
 
          Append_To (Stmts,
            Make_Implicit_If_Statement (N,
-             Condition => Make_Op_Not (Loc,
+             Condition =>
+               Make_Op_Not (Loc,
                  New_Reference_To (Cancel_Param, Loc)),
              Then_Statements => Tstats));
 
@@ -4684,7 +5571,7 @@ package body Exp_Ch9 is
              Parameter_Associations => Empty_List));
       end if;
 
-      Set_Entry_Cancel_Parameter (Blkent, Cancel_Param);
+      Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param);
 
       --  The result is the new block
 
@@ -4786,21 +5673,199 @@ package body Exp_Ch9 is
    --         ...
    --    end;
 
+   --  Ada 2005 (AI-345): A dispatching conditional entry call is converted
+   --  into:
+
+   --    declare
+   --       B : Boolean := False;
+   --       C : Ada.Tags.Prim_Op_Kind;
+   --       P : Parameters := (Param1 .. ParamN);
+   --       S : constant Integer := DT_Position (<dispatching-procedure>);
+
+   --    begin
+   --       disp_conditional_select (<object>, S, P'address, C, B);
+
+   --       if C = POK_Protected_Entry
+   --         or else C = POK_Task_Entry
+   --       then
+   --          Param1 := P.Param1;
+   --          ...
+   --          ParamN := P.ParamN;
+   --       end if;
+
+   --       if B then
+   --          if C = POK_Procedure
+   --            or else C = POK_Protected_Procedure
+   --            or else C = POK_Task_Procedure
+   --          then
+   --             <dispatching-procedure> (<object>, Param1 .. ParamN);
+   --          end if;
+   --          <normal-statements>
+   --       else
+   --          <else-statements>
+   --       end if;
+   --    end;
+
    procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is
       Loc : constant Source_Ptr := Sloc (N);
       Alt : constant Node_Id    := Entry_Call_Alternative (N);
       Blk : Node_Id             := Entry_Call_Statement (Alt);
       Transient_Blk : Node_Id;
 
-      Parms   : List_Id;
-      Parm    : Node_Id;
+      Actuals  : List_Id;
+      Blk_Typ  : Entity_Id;
       Call     : Node_Id;
-      Stmts   : List_Id;
-      B       : Entity_Id;
+      Call_Ent : Entity_Id;
       Decl     : Node_Id;
+      Decls    : List_Id;
+      Formals  : List_Id;
+      N_Stats  : List_Id;
+      Obj      : Entity_Id;
+      Param    : Node_Id;
+      Params   : List_Id;
       Stmt     : Node_Id;
+      Stmts    : List_Id;
+
+      B        : Entity_Id;  --  Call status flag
+      C        : Entity_Id;  --  Call kind
+      P        : Node_Id;    --  Parameter block
+      S        : Entity_Id;  --  Primitive operation slot
 
    begin
+      if Ada_Version >= Ada_05
+        and then Nkind (Blk) = N_Procedure_Call_Statement
+      then
+         Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals);
+
+         Decls := New_List;
+         Stmts := New_List;
+
+         --  Call status flag processing, generate:
+         --    B : Boolean := False;
+
+         B := SEU.Build_B (Loc, Decls);
+
+         --  Call kind processing, generate:
+         --    C : Ada.Tags.Prim_Op_Kind;
+
+         C := SEU.Build_C (Loc, Decls);
+
+         --  Parameter block processing
+
+         Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
+         P       := Parameter_Block_Pack  (Loc, Blk_Typ, Actuals, Formals,
+                      Decls, Stmts);
+
+         --  Dispatch table slot processing, generate:
+         --    S : constant Integer :=
+         --          DT_Position (<dispatching-procedure>);
+
+         S := SEU.Build_S (Loc, Decls, Call_Ent);
+
+         --  Generate:
+         --    _dispatching_conditional_select (<object>, S, P'address, C, B);
+
+         Append_To (Stmts,
+           Make_Procedure_Call_Statement (Loc,
+             Name =>
+               Make_Identifier (Loc, Name_uDisp_Conditional_Select),
+             Parameter_Associations =>
+               New_List (
+                 New_Copy_Tree    (Obj),
+                 New_Reference_To (S, Loc),
+                 P,
+                 New_Reference_To (C, Loc),
+                 New_Reference_To (B, Loc))));
+
+         --  Generate:
+         --    if C = POK_Protected_Entry
+         --      or else C = POK_Task_Entry
+         --    then
+         --       Param1 := P.Param1;
+         --       ...
+         --       ParamN := P.ParamN;
+         --    end if;
+
+         Append_To (Stmts,
+           Make_If_Statement (Loc,
+
+             Condition =>
+               Make_Or_Else (Loc,
+                 Left_Opnd =>
+                   Make_Op_Eq (Loc,
+                     Left_Opnd =>
+                       New_Reference_To (C, Loc),
+                     Right_Opnd =>
+                       New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)),
+                 Right_Opnd =>
+                   Make_Op_Eq (Loc,
+                     Left_Opnd =>
+                       New_Reference_To (C, Loc),
+                     Right_Opnd =>
+                       New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
+
+             Then_Statements =>
+               Parameter_Block_Unpack (Loc, Actuals, Formals)));
+
+         --  Generate:
+         --    if B then
+         --       if C = POK_Procedure
+         --         or else C = POK_Protected_Procedure
+         --         or else C = POK_Task_Procedure
+         --       then
+         --          <dispatching-procedure-call>
+         --       end if;
+         --       <normal-statements>
+         --    else
+         --       <else-statements>
+         --    end if;
+
+         N_Stats := New_Copy_List (Statements (Alt));
+
+         Prepend_To (N_Stats,
+           Make_If_Statement (Loc,
+             Condition =>
+               Make_Or_Else (Loc,
+                 Left_Opnd =>
+                   Make_Op_Eq (Loc,
+                     Left_Opnd =>
+                       New_Reference_To (C, Loc),
+                     Right_Opnd =>
+                       New_Reference_To (RTE (RE_POK_Procedure), Loc)),
+
+                 Right_Opnd =>
+                   Make_Or_Else (Loc,
+                     Left_Opnd =>
+                       Make_Op_Eq (Loc,
+                         Left_Opnd =>
+                           New_Reference_To (C, Loc),
+                         Right_Opnd =>
+                           New_Reference_To (RTE (
+                             RE_POK_Protected_Procedure), Loc)),
+
+                     Right_Opnd =>
+                       Make_Op_Eq (Loc,
+                         Left_Opnd =>
+                           New_Reference_To (C, Loc),
+                         Right_Opnd =>
+                           New_Reference_To (RTE (
+                             RE_POK_Task_Procedure), Loc)))),
+
+             Then_Statements =>
+               New_List (Blk)));
+
+         Append_To (Stmts,
+           Make_If_Statement (Loc,
+             Condition       => New_Reference_To (B, Loc),
+             Then_Statements => N_Stats,
+             Else_Statements => Else_Statements (N)));
+
+         Rewrite (N,
+           Make_Block_Statement (Loc,
+             Declarations               => Decls,
+             Handled_Statement_Sequence =>
+               Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
+
       --  As described above, The entry alternative is transformed into a
       --  block that contains the gnulli call, and possibly assignment
       --  statements for in-out parameters. The gnulli call may itself be
@@ -4808,52 +5873,48 @@ package body Exp_Ch9 is
       --  require it. We need to retrieve the call to complete its parameter
       --  list.
 
+      else
          Transient_Blk :=
             First_Real_Statement (Handled_Statement_Sequence (Blk));
 
          if Present (Transient_Blk)
-        and then
-        Nkind (Transient_Blk) =  N_Block_Statement
+           and then Nkind (Transient_Blk) = N_Block_Statement
          then
             Blk := Transient_Blk;
          end if;
 
          Stmts := Statements (Handled_Statement_Sequence (Blk));
-
          Stmt  := First (Stmts);
-
          while Nkind (Stmt) /= N_Procedure_Call_Statement loop
             Next (Stmt);
          end loop;
 
          Call   := Stmt;
-
-      Parms := Parameter_Associations (Call);
+         Params := Parameter_Associations (Call);
 
          if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then
 
-         --  Substitute Conditional_Entry_Call for Simple_Call
-         --  parameter.
+            --  Substitute Conditional_Entry_Call for Simple_Call parameter
 
-         Parm := First (Parms);
-         while Present (Parm)
-           and then not Is_RTE (Etype (Parm), RE_Call_Modes)
+            Param := First (Params);
+            while Present (Param)
+              and then not Is_RTE (Etype (Param), RE_Call_Modes)
             loop
-            Next (Parm);
+               Next (Param);
             end loop;
 
-         pragma Assert (Present (Parm));
-         Rewrite (Parm, New_Reference_To (RTE (RE_Conditional_Call), Loc));
+            pragma Assert (Present (Param));
+            Rewrite (Param, New_Reference_To (RTE (RE_Conditional_Call), Loc));
 
-         Analyze (Parm);
+            Analyze (Param);
 
-         --  Find the Communication_Block parameter for the call
-         --  to the Cancelled function.
+            --  Find the Communication_Block parameter for the call to the
+            --  Cancelled function.
 
             Decl := First (Declarations (Blk));
             while Present (Decl)
-           and then not
-             Is_RTE (Etype (Object_Definition (Decl)), RE_Communication_Block)
+              and then not Is_RTE (Etype (Object_Definition (Decl)),
+                             RE_Communication_Block)
             loop
                Next (Decl);
             end loop;
@@ -4882,17 +5943,19 @@ package body Exp_Ch9 is
             Prepend_To (Declarations (Blk),
               Make_Object_Declaration (Loc,
                 Defining_Identifier => B,
-           Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
+                Object_Definition =>
+                  New_Reference_To (Standard_Boolean, Loc)));
 
             --  Create new call statement
 
-         Append_To (Parms, New_Reference_To (RTE (RE_Conditional_Call), Loc));
-         Append_To (Parms, New_Reference_To (B, Loc));
+            Append_To (Params,
+              New_Reference_To (RTE (RE_Conditional_Call), Loc));
+            Append_To (Params, New_Reference_To (B, Loc));
 
             Rewrite (Call,
               Make_Procedure_Call_Statement (Loc,
                 Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
-             Parameter_Associations => Parms));
+                Parameter_Associations => Params));
 
             --  Construct statement sequence for new block
 
@@ -4901,7 +5964,6 @@ package body Exp_Ch9 is
                 Condition => New_Reference_To (B, Loc),
                 Then_Statements => Statements (Alt),
                 Else_Statements => Else_Statements (N)));
-
          end if;
 
          --  The result is the new block
@@ -4911,6 +5973,7 @@ package body Exp_Ch9 is
              Declarations => Declarations (Blk),
              Handled_Statement_Sequence =>
                Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
+      end if;
 
       Analyze (N);
    end Expand_N_Conditional_Entry_Call;
@@ -4925,7 +5988,6 @@ package body Exp_Ch9 is
 
    procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is
       Loc : constant Source_Ptr := Sloc (N);
-
    begin
       Rewrite (N,
         Make_Procedure_Call_Statement (Loc,
@@ -5193,7 +6255,7 @@ package body Exp_Ch9 is
    --     <sequence of statements>
    --  end pprocN;
 
-   --  procedure pproc (_object : in out poV;...) is
+   --  procedure pprocP (_object : in out poV;...) is
    --     procedure _clean is
    --       Pn : Boolean;
    --     begin
@@ -5217,7 +6279,7 @@ package body Exp_Ch9 is
    --     <sequence of statements>
    --  end pfuncN;
 
-   --  function pfunc (_object : poV) return Return_Type is
+   --  function pfuncP (_object : poV) return Return_Type is
    --     procedure _clean is
    --     begin
    --        Unlock (_object._object'Access);
@@ -5264,10 +6326,97 @@ package body Exp_Ch9 is
       Op_Decl      : Node_Id;
       Op_Body      : Node_Id;
       Op_Id        : Entity_Id;
+      Disp_Op_Body : Node_Id;
       New_Op_Body  : Node_Id;
       Current_Node : Node_Id;
       Num_Entries  : Natural := 0;
 
+      function Build_Dispatching_Subprogram_Body
+        (N        : Node_Id;
+         Pid      : Node_Id;
+         Prot_Bod : Node_Id) return Node_Id;
+      --  Build a dispatching version of the protected subprogram body. The
+      --  newly generated subprogram contains a call to the original protected
+      --  body. The following code is generated:
+      --
+      --  function <protected-function-name> (Param1 .. ParamN) return
+      --    <return-type> is
+      --  begin
+      --     return <protected-function-name>P (Param1 .. ParamN);
+      --  end <protected-function-name>;
+      --
+      --  or
+      --
+      --  procedure <protected-procedure-name> (Param1 .. ParamN) is
+      --  begin
+      --     <protected-procedure-name>P (Param1 .. ParamN);
+      --  end <protected-procedure-name>
+
+      ---------------------------------------
+      -- Build_Dispatching_Subprogram_Body --
+      ---------------------------------------
+
+      function Build_Dispatching_Subprogram_Body
+        (N        : Node_Id;
+         Pid      : Node_Id;
+         Prot_Bod : Node_Id) return Node_Id
+      is
+         Loc     : constant Source_Ptr := Sloc (N);
+         Actuals : List_Id;
+         Formal  : Node_Id;
+         Spec    : Node_Id;
+         Stmts   : List_Id;
+
+      begin
+         --  Generate a specification without a letter suffix in order to
+         --  override an interface function or procedure.
+
+         Spec :=
+           Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode);
+
+         --  The formal parameters become the actuals of the protected
+         --  function or procedure call.
+
+         Actuals := New_List;
+         Formal  := First (Parameter_Specifications (Spec));
+
+         while Present (Formal) loop
+            Append_To (Actuals,
+              Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
+
+            Next (Formal);
+         end loop;
+
+         if Nkind (Spec) = N_Procedure_Specification then
+            Stmts :=
+              New_List (
+                Make_Procedure_Call_Statement (Loc,
+                  Name =>
+                    New_Reference_To (Corresponding_Spec (Prot_Bod), Loc),
+                  Parameter_Associations => Actuals));
+         else
+            pragma Assert (Nkind (Spec) = N_Function_Specification);
+
+            Stmts :=
+              New_List (
+                Make_Return_Statement (Loc,
+                  Expression =>
+                    Make_Function_Call (Loc,
+                      Name =>
+                        New_Reference_To (Corresponding_Spec (Prot_Bod), Loc),
+                      Parameter_Associations => Actuals)));
+         end if;
+
+         return
+           Make_Subprogram_Body (Loc,
+             Declarations  => Empty_List,
+             Specification => Spec,
+             Handled_Statement_Sequence =>
+               Make_Handled_Sequence_Of_Statements (Loc, Stmts));
+      end Build_Dispatching_Subprogram_Body;
+
+   --  Start of processing for Expand_N_Protected_Body
+
    begin
       if No_Run_Time_Mode then
          Error_Msg_CRT ("protected body", N);
@@ -5340,6 +6489,26 @@ package body Exp_Ch9 is
 
                         Insert_After (Current_Node, New_Op_Body);
                         Analyze (New_Op_Body);
+
+                        Current_Node := New_Op_Body;
+
+                        --  Generate an overriding primitive operation body for
+                        --  this subprogram if the protected type implements
+                        --  an inerface.
+
+                        if Ada_Version >= Ada_05
+                          and then Present (Abstract_Interfaces (
+                                     Corresponding_Record_Type (Pid)))
+                        then
+                           Disp_Op_Body :=
+                             Build_Dispatching_Subprogram_Body (
+                               Op_Body, Pid, New_Op_Body);
+
+                           Insert_After (Current_Node, Disp_Op_Body);
+                           Analyze (Disp_Op_Body);
+
+                           Current_Node := Disp_Op_Body;
+                        end if;
                      end if;
                   end if;
                end if;
@@ -5723,7 +6892,13 @@ package body Exp_Ch9 is
                      Sloc => Loc,
                      Constraints => New_List (Entry_Count_Expr)));
 
-         elsif Has_Entries (Prottyp) then
+         --  The type has explicit entries or generated primitive entry
+         --  wrappers.
+
+         elsif Has_Entries (Prottyp)
+           or else (Ada_Version >= Ada_05
+                      and then Present (Interface_List (N)))
+         then
             if Abort_Allowed
               or else Restriction_Active (No_Entry_Queue) = False
               or else Number_Entries (Prottyp) > 1
@@ -5795,7 +6970,7 @@ package body Exp_Ch9 is
                  Make_Subprogram_Declaration (Loc,
                    Specification =>
                      Build_Protected_Sub_Specification
-                       (Priv, Prottyp, Unprotected => True));
+                       (Priv, Prottyp, Unprotected_Mode));
 
                Insert_After (Current_Node, Sub);
                Analyze (Sub);
@@ -5805,6 +6980,7 @@ package body Exp_Ch9 is
                   Defining_Unit_Name (Specification (Sub)));
 
                Current_Node := Sub;
+
                if Is_Interrupt_Handler
                  (Defining_Unit_Name (Specification (Priv)))
                then
@@ -5812,7 +6988,7 @@ package body Exp_Ch9 is
                     Make_Subprogram_Declaration (Loc,
                       Specification =>
                         Build_Protected_Sub_Specification
-                          (Priv, Prottyp, Unprotected => False));
+                          (Priv, Prottyp, Protected_Mode));
 
                   Insert_After (Current_Node, Sub);
                   Analyze (Sub);
@@ -5939,7 +7115,7 @@ package body Exp_Ch9 is
               Make_Subprogram_Declaration (Loc,
                 Specification =>
                   Build_Protected_Sub_Specification
-                    (Comp, Prottyp, Unprotected => True));
+                    (Comp, Prottyp, Unprotected_Mode));
 
             Insert_After (Current_Node, Sub);
             Analyze (Sub);
@@ -5957,11 +7133,32 @@ package body Exp_Ch9 is
               Make_Subprogram_Declaration (Loc,
                 Specification =>
                   Build_Protected_Sub_Specification
-                    (Comp, Prottyp, Unprotected => False));
+                    (Comp, Prottyp, Protected_Mode));
+
+            Insert_After (Current_Node, Sub);
+            Analyze (Sub);
+
+            Current_Node := Sub;
+
+            --  Generate an overriding primitive operation specification for
+            --  this subprogram if the protected type implements an inerface.
+
+            if Ada_Version >= Ada_05
+              and then
+                Present (Abstract_Interfaces
+                          (Corresponding_Record_Type (Prottyp)))
+            then
+               Sub :=
+                 Make_Subprogram_Declaration (Loc,
+                   Specification =>
+                     Build_Protected_Sub_Specification
+                       (Comp, Prottyp, Dispatching_Mode));
 
                Insert_After (Current_Node, Sub);
                Analyze (Sub);
+
                Current_Node := Sub;
+            end if;
 
             --  If a pragma Interrupt_Handler applies, build and add
             --  a call to Register_Interrupt_Handler to the freezing actions
@@ -6042,7 +7239,6 @@ package body Exp_Ch9 is
 
       if Present (Private_Declarations (Pdef)) then
          Comp := First (Private_Declarations (Pdef));
-
          while Present (Comp) loop
             if Nkind (Comp) = N_Entry_Declaration then
                E_Count := E_Count + 1;
@@ -8160,6 +9356,40 @@ package body Exp_Ch9 is
    --       end if;
    --    end;
 
+   --  3) Ada 2005 (AI-345): When T.E is a dispatching procedure call;
+
+   --    declare
+   --       B  : Boolean := False;
+   --       C  : Ada.Tags.Prim_Op_Kind;
+   --       DX : Duration := To_Duration (D)
+   --       M  : Integer :=...;
+   --       P  : Parameters := (Param1 .. ParamN);
+   --       S  : constant Iteger := DT_Position (<dispatching-procedure>);
+
+   --    begin
+   --       disp_timed_select (<object>, S, P'Address, DX, M, C, B);
+
+   --       if C = POK_Protected_Entry
+   --         or else C = POK_Task_Entry
+   --       then
+   --          Param1 := P.Param1;
+   --          ...
+   --          ParamN := P.ParamN;
+   --       end if;
+
+   --       if B then
+   --          if C = POK_Procedure
+   --            or else C = POK_Protected_Procedure
+   --            or else C = POK_Task_Procedure
+   --          then
+   --             T.E;
+   --          end if;
+   --          S1;
+   --       else
+   --          S2;
+   --       end if;
+   --    end;
+
    procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
       Loc : constant Source_Ptr := Sloc (N);
 
@@ -8172,25 +9402,32 @@ package body Exp_Ch9 is
       D_Stats : constant List_Id :=
                   Statements (Delay_Alternative (N));
 
-      Stmts : List_Id;
-      Stmt  : Node_Id;
-      Parms : List_Id;
-      Parm  : Node_Id;
-
+      Actuals  : List_Id;
+      Blk_Typ  : Entity_Id;
+      Call     : Node_Id;
+      Call_Ent : Entity_Id;
       Concval  : Node_Id;
+      D_Conv   : Node_Id;
+      D_Disc   : Node_Id;
+      D_Type   : Entity_Id;
+      Decls    : List_Id;
+      Dummy    : Node_Id;
       Ename    : Node_Id;
+      Formals  : List_Id;
       Index    : Node_Id;
+      N_Stats  : List_Id;
+      Obj      : Entity_Id;
+      Param    : Node_Id;
+      Params   : List_Id;
+      Stmt     : Node_Id;
+      Stmts    : List_Id;
 
-      Decls : List_Id;
-      Disc  : Node_Id;
-      Conv  : Node_Id;
-      B     : Entity_Id;
-      D     : Entity_Id;
-      Dtyp  : Entity_Id;
-      M     : Entity_Id;
-
-      Call  : Node_Id;
-      Dummy : Node_Id;
+      B : Entity_Id;  --  Call status flag
+      C : Entity_Id;  --  Call kind
+      D : Entity_Id;  --  Delay
+      M : Entity_Id;  --  Delay mode
+      P : Node_Id;    --  Parameter block
+      S : Entity_Id;  --  Primitive operation slot
 
    begin
       --  The arguments in the call may require dynamic allocation, and the
@@ -8200,7 +9437,6 @@ package body Exp_Ch9 is
 
       if Nkind (E_Call) = N_Block_Statement then
          E_Call := First (Statements (Handled_Statement_Sequence (E_Call)));
-
          while Nkind (E_Call) /= N_Procedure_Call_Statement
            and then Nkind (E_Call) /= N_Entry_Call_Statement
          loop
@@ -8208,87 +9444,268 @@ package body Exp_Ch9 is
          end loop;
       end if;
 
-      --  Build an entry call using Simple_Entry_Call. We will use this as the
-      --  base for creating appropriate calls.
+      if Ada_Version >= Ada_05
+        and then Nkind (E_Call) = N_Procedure_Call_Statement
+      then
+         Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals);
+
+         Decls := New_List;
+         Stmts := New_List;
+
+      else
+         --  Build an entry call using Simple_Entry_Call
 
          Extract_Entry (E_Call, Concval, Ename, Index);
          Build_Simple_Entry_Call (E_Call, Concval, Ename, Index);
 
-      Stmts := Statements (Handled_Statement_Sequence (E_Call));
          Decls := Declarations (E_Call);
+         Stmts := Statements (Handled_Statement_Sequence (E_Call));
 
          if No (Decls) then
             Decls := New_List;
          end if;
+      end if;
+
+      --  Call status flag processing
+
+      if Ada_Version >= Ada_05
+        and then Nkind (E_Call) = N_Procedure_Call_Statement
+      then
+         --  Generate:
+         --    B : Boolean := False;
+
+         B := SEU.Build_B (Loc, Decls);
+
+      else
+         --  Generate:
+         --    B : Boolean;
+
+         B := Make_Defining_Identifier (Loc, Name_uB);
+
+         Prepend_To (Decls,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier =>
+               B,
+             Object_Definition =>
+               New_Reference_To (Standard_Boolean, Loc)));
+      end if;
+
+      --  Call kind processing
+
+      if Ada_Version >= Ada_05
+        and then Nkind (E_Call) = N_Procedure_Call_Statement
+      then
+         --  Generate:
+         --    C : Ada.Tags.Prim_Op_Kind;
+
+         C := SEU.Build_C (Loc, Decls);
+      end if;
+
+      --  Duration and mode processing
 
-      Dtyp := Base_Type (Etype (Expression (D_Stat)));
+      D_Type := Base_Type (Etype (Expression (D_Stat)));
 
       --  Use the type of the delay expression (Calendar or Real_Time)
       --  to generate the appropriate conversion.
 
       if Nkind (D_Stat) = N_Delay_Relative_Statement then
-         Disc := Make_Integer_Literal (Loc, 0);
-         Conv := Relocate_Node (Expression (D_Stat));
+         D_Disc := Make_Integer_Literal (Loc, 0);
+         D_Conv := Relocate_Node (Expression (D_Stat));
 
-      elsif Is_RTE (Dtyp, RO_CA_Time) then
-         Disc := Make_Integer_Literal (Loc, 1);
-         Conv := Make_Function_Call (Loc,
+      elsif Is_RTE (D_Type, RO_CA_Time) then
+         D_Disc := Make_Integer_Literal (Loc, 1);
+         D_Conv := Make_Function_Call (Loc,
            New_Reference_To (RTE (RO_CA_To_Duration), Loc),
            New_List (New_Copy (Expression (D_Stat))));
 
-      else pragma Assert (Is_RTE (Dtyp, RO_RT_Time));
-         Disc := Make_Integer_Literal (Loc, 2);
-         Conv := Make_Function_Call (Loc,
+      else pragma Assert (Is_RTE (D_Type, RO_RT_Time));
+         D_Disc := Make_Integer_Literal (Loc, 2);
+         D_Conv := Make_Function_Call (Loc,
            New_Reference_To (RTE (RO_RT_To_Duration), Loc),
            New_List (New_Copy (Expression (D_Stat))));
       end if;
 
-      --  Create Duration and Delay_Mode objects for passing a delay value
-
       D := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
-      M := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
+
+      --  Generate:
+      --    D : Duration;
 
       Append_To (Decls,
         Make_Object_Declaration (Loc,
-          Defining_Identifier => D,
-          Object_Definition => New_Reference_To (Standard_Duration, Loc)));
+          Defining_Identifier =>
+            D,
+          Object_Definition =>
+            New_Reference_To (Standard_Duration, Loc)));
+
+      M := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
+
+      --  Generate:
+      --    M : Integer := (0 | 1 | 2);
 
       Append_To (Decls,
         Make_Object_Declaration (Loc,
-          Defining_Identifier => M,
-          Object_Definition => New_Reference_To (Standard_Integer, Loc),
-          Expression        => Disc));
+          Defining_Identifier =>
+            M,
+          Object_Definition =>
+            New_Reference_To (Standard_Integer, Loc),
+          Expression =>
+            D_Disc));
 
-      B := Make_Defining_Identifier (Loc, Name_uB);
+      --  Do the assignement at this stage only because the evaluation of the
+      --  expression must not occur before (see ACVC C97302A).
 
-      --  Create a boolean object used for a return parameter
+      Append_To (Stmts,
+        Make_Assignment_Statement (Loc,
+          Name =>
+            New_Reference_To (D, Loc),
+          Expression =>
+            D_Conv));
 
-      Prepend_To (Decls,
-        Make_Object_Declaration (Loc,
-          Defining_Identifier => B,
-          Object_Definition => New_Reference_To (Standard_Boolean, Loc)));
+      --  Parameter block processing
 
-      Stmt := First (Stmts);
+      --  Manually create the parameter block for dispatching calls. In the
+      --  case of entries, the block has already been created during the call
+      --  to Build_Simple_Entry_Call.
+
+      if Ada_Version >= Ada_05
+        and then Nkind (E_Call) = N_Procedure_Call_Statement
+      then
+         Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
+         P       := Parameter_Block_Pack  (Loc, Blk_Typ, Actuals, Formals,
+                      Decls, Stmts);
+
+         --  Dispatch table slot processing, generate:
+         --    S : constant Integer :=
+         --          DT_Prosition (<dispatching-procedure>)
+
+         S := SEU.Build_S (Loc, Decls, Call_Ent);
+
+         --  Generate:
+         --    _dispatching_timed_select (Obj, S, P'address, D, M, C, B);
 
+         --  where Obj is the controlling formal parameter, S is the dispatch
+         --  table slot number of the dispatching operation, P is the wrapped
+         --  parameter block, D is the duration, M is the duration mode, C is
+         --  the call kind and B is the call status.
+
+         Params := New_List;
+
+         Append_To (Params, New_Copy_Tree    (Obj));
+         Append_To (Params, New_Reference_To (S, Loc));
+         Append_To (Params, P);
+         Append_To (Params, New_Reference_To (D, Loc));
+         Append_To (Params, New_Reference_To (M, Loc));
+         Append_To (Params, New_Reference_To (C, Loc));
+         Append_To (Params, New_Reference_To (B, Loc));
+
+         Append_To (Stmts,
+           Make_Procedure_Call_Statement (Loc,
+             Name =>
+               Make_Identifier (Loc, Name_uDisp_Timed_Select),
+             Parameter_Associations =>
+               Params));
+
+         --  Generate:
+         --    if C = POK_Protected_Entry
+         --      or else C = POK_Task_Entry
+         --    then
+         --       Param1 := P.Param1;
+         --       ...
+         --       ParamN := P.ParamN;
+         --    end if;
+
+         Append_To (Stmts,
+           Make_If_Statement (Loc,
+
+             Condition =>
+               Make_Or_Else (Loc,
+                 Left_Opnd =>
+                   Make_Op_Eq (Loc,
+                     Left_Opnd =>
+                       New_Reference_To (C, Loc),
+                     Right_Opnd =>
+                       New_Reference_To (RTE (RE_POK_Protected_Entry), Loc)),
+                 Right_Opnd =>
+                   Make_Op_Eq (Loc,
+                     Left_Opnd =>
+                       New_Reference_To (C, Loc),
+                     Right_Opnd =>
+                       New_Reference_To (RTE (RE_POK_Task_Entry), Loc))),
+
+             Then_Statements =>
+               Parameter_Block_Unpack (Loc, Actuals, Formals)));
+
+         --  Generate:
+         --    if B then
+         --       if C = POK_Procedure
+         --         or else C = POK_Protected_Procedure
+         --         or else C = POK_Task_Procedure
+         --       then
+         --          <dispatching-procedure-call>
+         --       end if;
+         --       <normal-statements>
+         --    else
+         --       <delay-statements>
+         --    end if;
+
+         N_Stats := New_Copy_List (E_Stats);
+
+         Prepend_To (N_Stats,
+           Make_If_Statement (Loc,
+
+             Condition =>
+               Make_Or_Else (Loc,
+                 Left_Opnd =>
+                   Make_Op_Eq (Loc,
+                     Left_Opnd =>
+                       New_Reference_To (C, Loc),
+                     Right_Opnd =>
+                       New_Reference_To (RTE (RE_POK_Procedure), Loc)),
+                 Right_Opnd =>
+                   Make_Or_Else (Loc,
+                     Left_Opnd =>
+                       Make_Op_Eq (Loc,
+                         Left_Opnd =>
+                           New_Reference_To (C, Loc),
+                         Right_Opnd =>
+                           New_Reference_To (RTE (
+                             RE_POK_Protected_Procedure), Loc)),
+                     Right_Opnd =>
+                       Make_Op_Eq (Loc,
+                         Left_Opnd =>
+                           New_Reference_To (C, Loc),
+                         Right_Opnd =>
+                           New_Reference_To (RTE (
+                             RE_POK_Task_Procedure), Loc)))),
+
+             Then_Statements =>
+               New_List (E_Call)));
+
+         Append_To (Stmts,
+           Make_If_Statement (Loc,
+             Condition       => New_Reference_To (B, Loc),
+             Then_Statements => N_Stats,
+             Else_Statements => D_Stats));
+      else
          --  Skip assignments to temporaries created for in-out parameters.
          --  This makes unwarranted assumptions about the shape of the expanded
          --  tree for the call, and should be cleaned up ???
 
+         Stmt := First (Stmts);
          while Nkind (Stmt) /= N_Procedure_Call_Statement loop
             Next (Stmt);
          end loop;
 
-      --  Do the assignement at this stage only because the evaluation of the
-      --  expression must not occur before (see ACVC C97302A).
+         --  Do the assignement at this stage only because the evaluation
+         --  of the expression must not occur before (see ACVC C97302A).
 
          Insert_Before (Stmt,
            Make_Assignment_Statement (Loc,
              Name => New_Reference_To (D, Loc),
-          Expression => Conv));
+             Expression => D_Conv));
 
          Call   := Stmt;
-
-      Parms := Parameter_Associations (Call);
+         Params := Parameter_Associations (Call);
 
          --  For a protected type, we build a Timed_Protected_Entry_Call
 
@@ -8296,32 +9713,31 @@ package body Exp_Ch9 is
 
             --  Create a new call statement
 
-         Parm := First (Parms);
-
-         while Present (Parm)
-           and then not Is_RTE (Etype (Parm), RE_Call_Modes)
+            Param := First (Params);
+            while Present (Param)
+              and then not Is_RTE (Etype (Param), RE_Call_Modes)
             loop
-            Next (Parm);
+               Next (Param);
             end loop;
 
-         Dummy := Remove_Next (Next (Parm));
+            Dummy := Remove_Next (Next (Param));
 
             --  Remove garbage is following the Cancel_Param if present
 
-         Dummy := Next (Parm);
+            Dummy := Next (Param);
 
-         --  Remove the mode of the Protected_Entry_Call call, then remove the
-         --  Communication_Block of the Protected_Entry_Call call, and finally
-         --  add Duration and a Delay_Mode parameter
+            --  Remove the mode of the Protected_Entry_Call call, then remove
+            --  the Communication_Block of the Protected_Entry_Call call, and
+            --  finally add Duration and a Delay_Mode parameter
 
-         pragma Assert (Present (Parm));
-         Rewrite (Parm, New_Reference_To (D, Loc));
+            pragma Assert (Present (Param));
+            Rewrite (Param, New_Reference_To (D, Loc));
 
             Rewrite (Dummy, New_Reference_To (M, Loc));
 
             --  Add a Boolean flag for successful entry call
 
-         Append_To (Parms, New_Reference_To (B, Loc));
+            Append_To (Params, New_Reference_To (B, Loc));
 
             if Abort_Allowed
               or else Restriction_Active (No_Entry_Queue) = False
@@ -8330,25 +9746,24 @@ package body Exp_Ch9 is
                Rewrite (Call,
                  Make_Procedure_Call_Statement (Loc,
                    Name =>
-                  New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
-                Parameter_Associations => Parms));
-
+                     New_Reference_To (RTE (
+                       RE_Timed_Protected_Entry_Call), Loc),
+                   Parameter_Associations => Params));
             else
-            Parm := First (Parms);
-
-            while Present (Parm)
-              and then not Is_RTE (Etype (Parm), RE_Protected_Entry_Index)
+               Param := First (Params);
+               while Present (Param)
+                 and then not Is_RTE (Etype (Param), RE_Protected_Entry_Index)
                loop
-               Next (Parm);
+                  Next (Param);
                end loop;
 
-            Remove (Parm);
+               Remove (Param);
 
                Rewrite (Call,
                  Make_Procedure_Call_Statement (Loc,
                    Name => New_Reference_To (
                      RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
-                Parameter_Associations => Parms));
+                   Parameter_Associations => Params));
             end if;
 
          --  For the task case, build a Timed_Task_Entry_Call
@@ -8356,15 +9771,15 @@ package body Exp_Ch9 is
          else
             --  Create a new call statement
 
-         Append_To (Parms, New_Reference_To (D, Loc));
-         Append_To (Parms, New_Reference_To (M, Loc));
-         Append_To (Parms, New_Reference_To (B, Loc));
+            Append_To (Params, New_Reference_To (D, Loc));
+            Append_To (Params, New_Reference_To (M, Loc));
+            Append_To (Params, New_Reference_To (B, Loc));
 
             Rewrite (Call,
               Make_Procedure_Call_Statement (Loc,
-             Name => New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
-             Parameter_Associations => Parms));
-
+                Name =>
+                  New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
+                Parameter_Associations => Params));
          end if;
 
          Append_To (Stmts,
@@ -8372,6 +9787,7 @@ package body Exp_Ch9 is
              Condition => New_Reference_To (B, Loc),
              Then_Statements => E_Stats,
              Else_Statements => D_Stats));
+      end if;
 
       Rewrite (N,
         Make_Block_Statement (Loc,
@@ -8481,6 +9897,55 @@ package body Exp_Ch9 is
       end if;
    end External_Subprogram;
 
+   ------------------------------
+   -- Extract_Dispatching_Call --
+   ------------------------------
+
+   procedure Extract_Dispatching_Call
+     (N        : Node_Id;
+      Call_Ent : out Entity_Id;
+      Object   : out Entity_Id;
+      Actuals  : out List_Id;
+      Formals  : out List_Id)
+   is
+      Call_Nam : Node_Id;
+
+   begin
+      pragma Assert (Nkind (N) = N_Procedure_Call_Statement);
+
+      if Present (Original_Node (N)) then
+         Call_Nam := Name (Original_Node (N));
+      else
+         Call_Nam := Name (N);
+      end if;
+
+      --  Retrieve the name of the dispatching procedure. It contains the
+      --  dispatch table slot number.
+
+      loop
+         case Nkind (Call_Nam) is
+            when N_Identifier =>
+               exit;
+
+            when N_Selected_Component =>
+               Call_Nam := Selector_Name (Call_Nam);
+
+            when others =>
+               raise Program_Error;
+
+         end case;
+      end loop;
+
+      Actuals  := Parameter_Associations (N);
+      Call_Ent := Entity (Call_Nam);
+      Formals  := Parameter_Specifications (Parent (Call_Ent));
+      Object   := First (Actuals);
+
+      if Present (Original_Node (Object)) then
+         Object := Original_Node (Object);
+      end if;
+   end Extract_Dispatching_Call;
+
    -------------------
    -- Extract_Entry --
    -------------------
@@ -8502,15 +9967,13 @@ package body Exp_Ch9 is
          Ename   := Selector_Name (Nam);
          Index   := Empty;
 
-         --  For a member of an entry family, the name is an indexed
-         --  component where the prefix is a selected component,
-         --  whose prefix in turn is the task value, and whose
-         --  selector is the entry family. The single expression in
-         --  the expressions list of the indexed component is the
+      --  For a member of an entry family, the name is an indexed component
+      --  where the prefix is a selected component, whose prefix in turn is
+      --  the task value, and whose selector is the entry family. The single
+      --  expression in the expressions list of the indexed component is the
       --  subscript for the family.
 
-      else
-         pragma Assert (Nkind (Nam) = N_Indexed_Component);
+      else pragma Assert (Nkind (Nam) = N_Indexed_Component);
          Concval := Prefix (Prefix (Nam));
          Ename   := Selector_Name (Prefix (Nam));
          Index   := First (Expressions (Nam));
@@ -8899,6 +10362,8 @@ package body Exp_Ch9 is
       if Has_Entry
         or else Has_Interrupt_Handler (Ptyp)
         or else Has_Attach_Handler (Ptyp)
+        or else (Ada_Version >= Ada_05
+                   and then Present (Interface_List (Parent (Ptyp))))
       then
          --  Compiler_Info parameter. This parameter allows entry body
          --  procedures and barrier functions to be called from the runtime.
@@ -9287,6 +10752,168 @@ package body Exp_Ch9 is
       return Next_Op;
    end Next_Protected_Operation;
 
+   --------------------------
+   -- Parameter_Block_Pack --
+   --------------------------
+
+   function Parameter_Block_Pack
+     (Loc     : Source_Ptr;
+      Blk_Typ : Entity_Id;
+      Actuals : List_Id;
+      Formals : List_Id;
+      Decls   : List_Id;
+      Stmts   : List_Id) return Node_Id
+   is
+      Actual   : Entity_Id;
+      Blk_Nam  : Node_Id;
+      Formal   : Entity_Id;
+      Params   : List_Id;
+      Temp_Asn : Node_Id;
+      Temp_Nam : Node_Id;
+
+   begin
+      Actual := First (Actuals);
+      Formal := Defining_Identifier (First (Formals));
+      Params := New_List;
+
+      while Present (Actual) loop
+         if Is_By_Copy_Type (Etype (Actual)) then
+            --  Generate:
+            --    Jnn : aliased <formal-type>
+
+            Temp_Nam :=
+              Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
+
+            Append_To (Decls,
+              Make_Object_Declaration (Loc,
+                Aliased_Present =>
+                  True,
+                Defining_Identifier =>
+                  Temp_Nam,
+                Object_Definition =>
+                  New_Reference_To (Etype (Formal), Loc)));
+
+            if Ekind (Formal) /= E_Out_Parameter then
+
+               --  Generate:
+               --    Jnn := <actual>
+
+               Temp_Asn :=
+                 New_Reference_To (Temp_Nam, Loc);
+
+               Set_Assignment_OK (Temp_Asn);
+
+               Append_To (Stmts,
+                 Make_Assignment_Statement (Loc,
+                   Name =>
+                     Temp_Asn,
+                   Expression =>
+                     New_Copy_Tree (Actual)));
+            end if;
+
+            --  Generate:
+            --    Jnn'unchecked_access
+
+            Append_To (Params,
+              Make_Attribute_Reference (Loc,
+                Attribute_Name =>
+                  Name_Unchecked_Access,
+                Prefix =>
+                  New_Reference_To (Temp_Nam, Loc)));
+         else
+            Append_To (Params,
+              Make_Reference (Loc, New_Copy_Tree (Actual)));
+         end if;
+
+         Next_Actual (Actual);
+         Next_Formal_With_Extras (Formal);
+      end loop;
+
+      --  Generate:
+      --    P : Ann := (
+      --      J1'unchecked_access;
+      --      <actual2>'reference;
+      --      ...);
+
+      Blk_Nam := Make_Defining_Identifier (Loc, Name_uP);
+
+      Append_To (Decls,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier =>
+            Blk_Nam,
+          Object_Definition =>
+            New_Reference_To (Blk_Typ, Loc),
+          Expression =>
+            Make_Aggregate (Loc, Params)));
+
+      --  Return:
+      --    P'address
+
+      return
+        Make_Attribute_Reference (Loc,
+          Attribute_Name =>
+            Name_Address,
+          Prefix =>
+            New_Reference_To (Blk_Nam, Loc));
+   end Parameter_Block_Pack;
+
+   ----------------------------
+   -- Parameter_Block_Unpack --
+   ----------------------------
+
+   function Parameter_Block_Unpack
+     (Loc     : Source_Ptr;
+      Actuals : List_Id;
+      Formals : List_Id) return List_Id
+   is
+      Actual : Entity_Id;
+      Asnmt  : Node_Id;
+      Formal : Entity_Id;
+      Result : constant List_Id := New_List;
+
+      At_Least_One_Asnmt : Boolean := False;
+
+   begin
+      Actual := First (Actuals);
+      Formal := Defining_Identifier (First (Formals));
+
+      while Present (Actual) loop
+         if Is_By_Copy_Type (Etype (Actual))
+           and then Ekind (Formal) /= E_In_Parameter
+         then
+            At_Least_One_Asnmt := True;
+
+            --  Generate:
+            --    <actual> := P.<formal>;
+
+            Asnmt :=
+              Make_Assignment_Statement (Loc,
+                Name =>
+                  New_Copy (Actual),
+                Expression =>
+                  Make_Explicit_Dereference (Loc,
+                    Make_Selected_Component (Loc,
+                      Prefix =>
+                        Make_Identifier (Loc, Name_uP),
+                      Selector_Name =>
+                        Make_Identifier (Loc, Chars (Formal)))));
+
+            Set_Assignment_OK (Name (Asnmt));
+
+            Append_To (Result, Asnmt);
+         end if;
+
+         Next_Actual (Actual);
+         Next_Formal_With_Extras (Formal);
+      end loop;
+
+      if At_Least_One_Asnmt then
+         return Result;
+      end if;
+
+      return New_List (Make_Null_Statement (Loc));
+   end Parameter_Block_Unpack;
+
    ----------------------
    -- Set_Discriminals --
    ----------------------
@@ -9302,7 +10929,6 @@ package body Exp_Ch9 is
 
       if Has_Discriminants (Pdef) then
          D := First_Discriminant (Pdef);
-
          while Present (D) loop
             D_Minal :=
               Make_Defining_Identifier (Sloc (D),
@@ -9366,11 +10992,10 @@ package body Exp_Ch9 is
                Set_Esize     (Priv, Esize (Etype (P_Id)));
                Set_Alignment (Priv, Alignment (Etype (P_Id)));
 
-               --  If the type of the component is an itype, we must
-               --  create a new itype for the corresponding prival in
-               --  each protected operation, to avoid scoping problems.
-               --  We create new itypes by copying the tree for the
-               --  component definition.
+               --  If the type of the component is an itype, we must create a
+               --  new itype for the corresponding prival in each protected
+               --  operation, to avoid scoping problems. We create new itypes
+               --  by copying the tree for the component definition.
 
                if Is_Itype (Etype (P_Id)) then
                   Append_Elmt (P_Id, Assoc_L);
@@ -9394,9 +11019,8 @@ package body Exp_Ch9 is
          end loop;
       end if;
 
-      --  There is one more implicit private declaration: the object
-      --  itself. A "prival" for this is attached to the protected
-      --  body defining identifier.
+      --  There is one more implicit private decl: the object itself. "prival"
+      --  for this is attached to the protected body defining identifier.
 
       Body_Ent := Corresponding_Body (Dec);
 
@@ -9492,11 +11116,12 @@ package body Exp_Ch9 is
             Update_Array_Bounds (Etype (Defining_Identifier (N)));
             return OK;
 
-         --  For array components of discriminated records, use the
-         --  base type directly, because it may depend indirectly
-         --  on the discriminants of the protected type. Cleaner would
-         --  be a systematic mechanism to compute actual subtypes of
-         --  private components ???
+         --  For array components of discriminated records, use the base type
+         --  directly, because it may depend indirectly on the discriminants of
+         --  the protected type.
+
+         --  Cleaner would be a systematic mechanism to compute actual subtypes
+         --  of private components???
 
          elsif Nkind (N) in N_Has_Etype
            and then Present (Etype (N))
@@ -9532,10 +11157,8 @@ package body Exp_Ch9 is
 
       procedure Update_Array_Bounds (E : Entity_Id) is
          Ind : Node_Id;
-
       begin
          Ind := First_Index (E);
-
          while Present (Ind) loop
             Update_Prival_Subtypes (Type_Low_Bound  (Etype (Ind)));
             Update_Prival_Subtypes (Type_High_Bound (Etype (Ind)));
@@ -9550,13 +11173,13 @@ package body Exp_Ch9 is
       procedure Update_Index_Types (N : Node_Id) is
          Indx1 : Node_Id;
          I_Typ : Node_Id;
+
       begin
-         --  If the prefix has an actual subtype that is different
-         --  from the nominal one, update the types of the indices,
-         --  so that the proper constraints are applied. Do not
-         --  apply this transformation to a packed array, where the
-         --  index type is computed for a byte array and is different
-         --  from the source index.
+         --  If the prefix has an actual subtype that is different from the
+         --  nominal one, update the types of the indices, so that the proper
+         --  constraints are applied. Do not apply this transformation to a
+         --  packed array, where the index type is computed for a byte array
+         --  and is different from the source index.
 
          if Nkind (Parent (N)) = N_Indexed_Component
            and then

gcc/ada/exp_ch9.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2004 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005 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- --
@@ -30,6 +30,13 @@ with Types; use Types;
 
 package Exp_Ch9 is
 
+   type Subprogram_Protection_Mode is
+     (Dispatching_Mode,
+      Protected_Mode,
+      Unprotected_Mode);
+   --  This type is used to distinguish the different protection modes of a
+   --  protected subprogram.
+
    procedure Add_Discriminal_Declarations
      (Decls : List_Id;
       Typ   : Entity_Id;
@@ -104,8 +111,7 @@ package Exp_Ch9 is
    function Build_Protected_Sub_Specification
      (N       : Node_Id;
       Prottyp : Entity_Id;
-      Unprotected : Boolean := False)
-      return        Node_Id;
+      Mode    : Subprogram_Protection_Mode) return Node_Id;
    --  Build specification for protected subprogram. This is called when
    --  expanding a protected type, and also when expanding the declaration for
    --  an Access_To_Protected_Subprogram type. In the latter case, Prottyp is
@@ -214,7 +220,7 @@ package Exp_Ch9 is
    --  routine to make sure Complete_Master is called on exit).
 
    procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id);
-   --  Build Equivalent_Type for an Access_to_protected_Subprogram.
+   --  Build Equivalent_Type for an Access_to_protected_Subprogram
 
    procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id);
    --  Expand declarations required for accept statement. See bodies of

gcc/ada/exp_disp.adb

@@ -49,19 +49,276 @@ with Sinfo;    use Sinfo;
 with Snames;   use Snames;
 with Stand;    use Stand;
 with Tbuild;   use Tbuild;
-with Ttypes;   use Ttypes;
 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;
+         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;
+         Stmts : List_Id)
+      is
+         DT_Ptr     : Entity_Id;
+         DT_Ptr_Typ : Entity_Id := Typ;
+
+      begin
+         --  Typ may be a derived type, climb the derivation chain in order to
+         --  find the root.
+
+         while Present (Parent_Subtype (DT_Ptr_Typ)) loop
+            DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
+         end loop;
+
+         DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_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.
+
+         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_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,
        Inherit_DT              => RE_Inherit_DT,
@@ -69,9 +326,11 @@ package body Exp_Disp is
        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_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_TSD                 => RE_Set_TSD,
@@ -84,8 +343,10 @@ package body Exp_Disp is
        DT_Entry_Size           => False,
        DT_Prologue_Size        => False,
        Get_Access_Level        => False,
+       Get_Entry_Index         => False,
        Get_External_Tag        => False,
        Get_Prim_Op_Address     => False,
+       Get_Prim_Op_Kind        => False,
        Get_Remotely_Callable   => False,
        Get_RC_Offset           => False,
        Inherit_DT              => True,
@@ -93,9 +354,11 @@ package body Exp_Disp is
        Register_Interface_Tag  => True,
        Register_Tag            => True,
        Set_Access_Level        => True,
+       Set_Entry_Index         => True,
        Set_Expanded_Name       => True,
        Set_External_Tag        => True,
        Set_Prim_Op_Address     => True,
+       Set_Prim_Op_Kind        => True,
        Set_RC_Offset           => True,
        Set_Remotely_Callable   => True,
        Set_TSD                 => True,
@@ -108,8 +371,10 @@ package body Exp_Disp is
        DT_Entry_Size           => 0,
        DT_Prologue_Size        => 0,
        Get_Access_Level        => 1,
+       Get_Entry_Index         => 2,
        Get_External_Tag        => 1,
        Get_Prim_Op_Address     => 2,
+       Get_Prim_Op_Kind        => 2,
        Get_RC_Offset           => 1,
        Get_Remotely_Callable   => 1,
        Inherit_DT              => 3,
@@ -117,21 +382,17 @@ package body Exp_Disp is
        Register_Interface_Tag  => 2,
        Register_Tag            => 1,
        Set_Access_Level        => 2,
+       Set_Entry_Index         => 3,
        Set_Expanded_Name       => 2,
        Set_External_Tag        => 2,
        Set_Prim_Op_Address     => 3,
+       Set_Prim_Op_Kind        => 3,
        Set_RC_Offset           => 2,
        Set_Remotely_Callable   => 2,
        Set_TSD                 => 2,
        TSD_Entry_Size          => 0,
        TSD_Prologue_Size       => 0);
 
-   function Build_Anonymous_Access_Type
-     (Directly_Designated_Type : Entity_Id;
-      Related_Nod              : Node_Id) return Entity_Id;
-   --  Returns a decorated entity corresponding with an anonymous access type.
-   --  Used to generate unchecked type conversion of an address.
-
    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
@@ -145,29 +406,12 @@ package body Exp_Disp is
    --  Check if the type has a private view or if the public view appears
    --  in the visible part of a package spec.
 
-   ----------------------------------
-   --  Build_Anonymous_Access_Type --
-   ----------------------------------
-
-   function Build_Anonymous_Access_Type
-     (Directly_Designated_Type : Entity_Id;
-      Related_Nod              : Node_Id) return Entity_Id
-   is
-      New_E : Entity_Id;
-
-   begin
-      New_E := Create_Itype (Ekind       => E_Anonymous_Access_Type,
-                             Related_Nod => Related_Nod,
-                             Scope_Id    => Current_Scope);
-
-      Set_Etype                    (New_E, New_E);
-      Init_Size_Align              (New_E);
-      Init_Size                    (New_E, System_Address_Size);
-      Set_Directly_Designated_Type (New_E, Directly_Designated_Type);
-      Set_Is_First_Subtype         (New_E);
-
-      return New_E;
-   end Build_Anonymous_Access_Type;
+   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 RTE Prim_Op_Kind
+   --  enumeration value.
 
    ----------------------------
    -- Collect_All_Interfaces --
@@ -187,9 +431,10 @@ package body Exp_Disp is
       -------------------
 
       procedure Add_Interface (Iface : Entity_Id) is
-         Elmt  : Elmt_Id := First_Elmt (Abstract_Interfaces (T));
+         Elmt : Elmt_Id;
 
       begin
+         Elmt := First_Elmt (Abstract_Interfaces (T));
          while Present (Elmt) and then Node (Elmt) /= Iface loop
             Next_Elmt (Elmt);
          end loop;
@@ -238,9 +483,7 @@ package body Exp_Disp is
 
          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
@@ -309,6 +552,18 @@ package body Exp_Disp is
       elsif TSS_Name = TSS_Deep_Finalize then
          return Uint_10;
 
+      elsif 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_Timed_Select then
+         return Uint_14;
+
       else
          raise Program_Error;
       end if;
@@ -373,9 +628,10 @@ package body Exp_Disp is
 
          else
             declare
-               Formal : Entity_Id := First_Formal (Subp);
+               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
@@ -441,6 +697,10 @@ package body Exp_Disp is
 
       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;
@@ -744,13 +1004,17 @@ package body Exp_Disp is
       Loc         : constant Source_Ptr := Sloc (N);
       Operand     : constant Node_Id    := Expression (N);
       Operand_Typ : Entity_Id           := Etype (Operand);
-      Target_Type : Entity_Id           := Etype (N);
+      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): Set Operand_Typ and Handle task interfaces
+      --  Ada 2005 (AI-345): Handle task interfaces
 
       if Ekind (Operand_Typ) = E_Task_Type
         or else Ekind (Operand_Typ) = E_Protected_Type
@@ -758,27 +1022,126 @@ package body Exp_Disp is
          Operand_Typ := Corresponding_Record_Type (Operand_Typ);
       end if;
 
-      if Is_Access_Type (Target_Type) then
-         Target_Type := Etype (Directly_Designated_Type (Target_Type));
+      --  Handle access types to interfaces
 
-      elsif Is_Class_Wide_Type (Target_Type) then
-         Target_Type := Etype (Target_Type);
+      if Is_Access_Type (Iface_Typ) then
+         Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
       end if;
 
-      pragma Assert (not Is_Class_Wide_Type (Target_Type)
-        and then Is_Interface (Target_Type));
+      --  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;
 
-      Iface_Tag := Find_Interface_Tag (Operand_Typ, Target_Type);
+      pragma Assert (not Is_Class_Wide_Type (Iface_Typ)
+        and then Is_Interface (Iface_Typ));
 
+      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_Selected_Component (Loc,
                                   Prefix => Relocate_Node (Expression (N)),
-                        Selector_Name => New_Occurrence_Of (Iface_Tag, Loc)),
-            Attribute_Name => Name_Address)));
+                                  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;
@@ -790,12 +1153,16 @@ package body Exp_Disp is
    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
@@ -818,45 +1185,70 @@ package body Exp_Disp is
 
       Formal := First_Formal (Subp);
       Actual := First_Actual (Call_Node);
-
       while Present (Formal) loop
 
-         pragma Assert (Ekind (Etype (Etype (Formal)))
-                        /= E_Record_Type_With_Private);
-
          --  Ada 2005 (AI-251): Conversion to interface to force "this"
-         --  displacement
+         --  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
 
-            Conversion := Convert_To (Formal_Typ, New_Copy_Tree (Actual));
-            Rewrite             (Actual, Conversion);
-            Analyze_And_Resolve (Actual, Formal_Typ);
+            --  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:
 
-            Rewrite (Actual,
-              Make_Explicit_Dereference (Loc,
-                Unchecked_Convert_To
-                  (Build_Anonymous_Access_Type (Formal_Typ, Call_Node),
-                   Relocate_Node (Expression (Actual)))));
+            --     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
-                                  (Directly_Designated_Type
-                                   (Formal_Typ)))
+           and then Is_Interface (Etype (Formal_DDT))
            and then Interface_Present_In_Ancestor
-                      (Typ   => Etype (Directly_Designated_Type
-                                        (Actual_Typ)),
-                       Iface => Etype (Directly_Designated_Type
-                                        (Formal_Typ)))
+                      (Typ   => Actual_DDT,
+                       Iface => Etype (Formal_DDT))
          then
-
             if Nkind (Actual) = N_Attribute_Reference
               and then
                (Attribute_Name (Actual) = Name_Access
@@ -864,28 +1256,84 @@ package body Exp_Disp is
             then
                Nam := Attribute_Name (Actual);
 
-               Conversion :=
-                 Convert_To
-                   (Etype (Directly_Designated_Type (Formal_Typ)),
-                    Prefix (Actual));
+               Conversion := Convert_To (Etype (Formal_DDT), Prefix (Actual));
 
                Rewrite (Actual, Conversion);
-
-               Analyze_And_Resolve (Actual,
-                 Etype (Directly_Designated_Type (Formal_Typ)));
+               Analyze_And_Resolve (Actual, Etype (Formal_DDT));
 
                Rewrite (Actual,
                  Unchecked_Convert_To (Formal_Typ,
                    Make_Attribute_Reference (Loc,
-                     Prefix =>
-                       Relocate_Node (Prefix (Expression (Actual))),
+                     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
-               Conversion :=
-                 Convert_To (Formal_Typ, New_Copy_Tree (Actual));
+               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;
@@ -904,40 +1352,38 @@ package body Exp_Disp is
      (N           : Node_Id;
       Thunk_Alias : Entity_Id;
       Thunk_Id    : Entity_Id;
-      Iface_Tag   : Entity_Id) return Node_Id
+      Thunk_Tag   : 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;
-      Thunk_Tag   : constant Node_Id    := Iface_Tag;
       Target      : Entity_Id;
       New_Code    : Node_Id;
       Formal      : Node_Id;
       New_Formal  : Node_Id;
       Decl_1      : Node_Id;
       Decl_2      : Node_Id;
-      Subtyp_Mark : 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 (Thunk_Alias);
-
+      Formal := First_Formal (Target);
+      E      := First_Formal (N);
       while Present (Formal) loop
          New_Formal := Copy_Separate_Tree (Parent (Formal));
 
-         --  Handle the case in which the subprogram covering
-         --  the interface has been inherited:
+         --  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;
@@ -948,20 +1394,17 @@ package body Exp_Disp is
 
          --     type DT is new T and I with ...
 
-         if Is_Controlling_Formal (Formal) then
-            Set_Parameter_Type (New_Formal,
-              New_Reference_To (Etype (First_Entity (N)), Loc));
-         end if;
-
+         Set_Parameter_Type (New_Formal, New_Reference_To (Etype (E), Loc));
          Append_To (Formals, New_Formal);
+
          Next_Formal (Formal);
+         Next_Formal (E);
       end loop;
 
-      if Ekind (First_Formal (Thunk_Alias)) = E_In_Parameter
-        and then Ekind (Etype (First_Formal (Thunk_Alias)))
+      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>>
@@ -983,8 +1426,7 @@ package body Exp_Disp is
                  Subtype_Indication     =>
                    New_Reference_To
                      (Directly_Designated_Type
-                        (Etype (First_Formal (Thunk_Alias))), Loc)
-                         ));
+                        (Etype (First_Formal (Target))), Loc)));
 
          Decl_1 :=
            Make_Object_Declaration (Loc,
@@ -1095,7 +1537,7 @@ package body Exp_Disp is
          Next (Formal);
       end loop;
 
-      if Ekind (Thunk_Alias) = E_Procedure then
+      if Ekind (Target) = E_Procedure then
          New_Code :=
            Make_Subprogram_Body (Loc,
               Specification =>
@@ -1110,23 +1552,7 @@ package body Exp_Disp is
                        Name => New_Occurrence_Of (Target, Loc),
                        Parameter_Associations => Actuals))));
 
-      else pragma Assert (Ekind (Thunk_Alias) = E_Function);
-
-         if not Present (Alias (Thunk_Alias)) then
-            Subtyp_Mark := Subtype_Mark (Parent (Thunk_Alias));
-         else
-            --  The last element in the alias list has the correct subtype_mark
-            --  of the function result
-
-            declare
-               E : Entity_Id := Alias (Thunk_Alias);
-            begin
-               while Present (Alias (E)) loop
-                  E := Alias (E);
-               end loop;
-               Subtyp_Mark := Subtype_Mark (Parent (E));
-            end;
-         end if;
+      else pragma Assert (Ekind (Target) = E_Function);
 
          New_Code :=
            Make_Subprogram_Body (Loc,
@@ -1134,7 +1560,8 @@ package body Exp_Disp is
                 Make_Function_Specification (Loc,
                   Defining_Unit_Name       => Thunk_Id,
                   Parameter_Specifications => Formals,
-                  Subtype_Mark => New_Copy (Subtyp_Mark)),
+                  Result_Definition =>
+                    New_Copy (Result_Definition (Parent (Target)))),
               Declarations => Decl,
               Handled_Statement_Sequence =>
                 Make_Handled_Sequence_Of_Statements (Loc,
@@ -1234,6 +1661,49 @@ package body Exp_Disp is
              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 it an abstract interface type
+
+      if Is_Interface (Typ) 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, Default_Prim_Op_Count);
+
+         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, Default_Prim_Op_Count))));
+
+         Next_Elmt (AI);
+      end loop;
+
+      return Result;
+   end Init_Predefined_Interface_Primitives;
+
    -------------
    -- Make_DT --
    -------------
@@ -1284,7 +1754,6 @@ package body Exp_Disp is
 
       Num_Ifaces := 0;
       AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
-
       while Present (AI) loop
          Num_Ifaces := Num_Ifaces + 1;
          Next_Elmt (AI);
@@ -1300,7 +1769,6 @@ package body Exp_Disp is
 
       begin
          I_Depth := 0;
-
          loop
             P := Etype (Parent_Type);
 
@@ -1315,9 +1783,25 @@ package body Exp_Disp is
          end loop;
       end;
 
-      TSD_Num_Entries := I_Depth + Num_Ifaces + 1;
       Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
 
+      --  Ada 2005 (AI-345): The size of the TSD is increased to accomodate
+      --  the two tables used for dispatching in asynchronous, conditional
+      --  and timed selects. The tables are solely generated for limited
+      --  types that implement a limited interface.
+
+      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 Implements_Limited_Interface (Typ)
+      then
+         TSD_Num_Entries := I_Depth + Num_Ifaces + 1 +
+                              2 * (Nb_Prim - Default_Prim_Op_Count);
+      else
+         TSD_Num_Entries := I_Depth + Num_Ifaces + 1;
+      end if;
+
       --  ----------------------------------------------------------------
       --  Dispatch table and related entities are allocated statically
 
@@ -1400,7 +1884,7 @@ package body Exp_Disp is
 
       --  Generate code to define the boolean that controls registration, in
       --  order to avoid multiple registrations for tagged types defined in
-      --  multiple-called scopes
+      --  multiple-called scopes.
 
       Append_To (Result,
         Make_Object_Declaration (Loc,
@@ -1418,7 +1902,7 @@ package body Exp_Disp is
 
       --  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)
+      --  of all the implemented interfaces (as described in a-tags.adb).
       --
       --   TSD: Storage_Array
       --     (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size);
@@ -1532,6 +2016,10 @@ package body Exp_Disp is
              (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
       end if;
 
+      if Typ /= Etype (Typ)
+        and then not Is_Interface (Typ)
+        and then not Is_Interface (Etype (Typ))
+      then
          --  Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
 
          Append_To (Elab_Code,
@@ -1540,7 +2028,8 @@ package body Exp_Disp is
              Args   => New_List (
                Node1 => Old_Tag1,
                Node2 => New_Reference_To (DT_Ptr, Loc),
-            Node3 => Make_Integer_Literal (Loc,
+               Node3 =>
+                 Make_Integer_Literal (Loc,
                    DT_Entry_Count (First_Tag_Component (Etype (Typ)))))));
 
          --  Inherit the secondary dispatch tables of the ancestor
@@ -1548,12 +2037,17 @@ package body Exp_Disp is
          if not Is_CPP_Class (Etype (Typ)) then
             declare
                Sec_DT_Ancestor : Elmt_Id :=
-              Next_Elmt (First_Elmt (Access_Disp_Table (Etype (Typ))));
+                                   Next_Elmt
+                                     (First_Elmt
+                                        (Access_Disp_Table (Etype (Typ))));
                Sec_DT_Typ      : Elmt_Id :=
-              Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+                                   Next_Elmt
+                                     (First_Elmt
+                                        (Access_Disp_Table (Typ)));
 
                procedure Copy_Secondary_DTs (Typ : Entity_Id);
-            --  ??? comment required
+               --  Local procedure required to climb through the ancestors and
+               --  copy the contents of all their secondary dispatch tables.
 
                ------------------------
                -- Copy_Secondary_DTs --
@@ -1572,7 +2066,6 @@ package body Exp_Disp is
                                    (Abstract_Interfaces (Typ))
                   then
                      E := First_Entity (Typ);
-
                      while Present (E)
                        and then Present (Node (Sec_DT_Ancestor))
                      loop
@@ -1607,8 +2100,10 @@ package body Exp_Disp is
                end if;
             end;
          end if;
+      end if;
 
-      --  Generate: Inherit_TSD (parent'tag, DT_Ptr);
+      --  Generate:
+      --    Inherit_TSD (parent'tag, DT_Ptr);
 
       Append_To (Elab_Code,
         Make_DT_Access_Action (Typ,
@@ -1962,6 +2457,832 @@ package body Exp_Disp is
       end if;
    end Make_DT_Access_Action;
 
+   ----------------------------------------
+   -- 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;
+      DT_Ptr_Typ : Entity_Id;
+      Loc        : constant Source_Ptr := Sloc (Typ);
+      Stmts      : constant List_Id    := New_List;
+
+   begin
+      if Is_Concurrent_Record_Type (Typ) then
+         Conc_Typ := Corresponding_Concurrent_Type (Typ);
+      end if;
+
+      --  Typ may be a derived type, climb the derivation chain in order to
+      --  find the root.
+
+      DT_Ptr_Typ := Typ;
+      while Present (Parent_Subtype (DT_Ptr_Typ)) loop
+         DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
+      end loop;
+
+      DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+
+      if Present (Conc_Typ) then
+
+         --  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;
+
+      --  Null implementation for limited tagged types
+
+      else
+         Append_To (Stmts,
+           Make_Null_Statement (Loc));
+      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);
+      Params : constant List_Id    := New_List;
+
+   begin
+      --  "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);
+
+      return
+         Make_Procedure_Specification (Loc,
+           Defining_Unit_Name =>
+             Make_Defining_Identifier (Loc, Name_uDisp_Asynchronous_Select),
+           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
+      Blk_Nam    : Entity_Id;
+      Conc_Typ   : Entity_Id         := Empty;
+      Decls      : constant List_Id  := New_List;
+      DT_Ptr     : Entity_Id;
+      DT_Ptr_Typ : Entity_Id;
+      Loc        : constant Source_Ptr := Sloc (Typ);
+      Stmts      : constant List_Id  := New_List;
+
+   begin
+      if Is_Concurrent_Record_Type (Typ) then
+         Conc_Typ := Corresponding_Concurrent_Type (Typ);
+      end if;
+
+      --  Typ may be a derived type, climb the derivation chain in order to
+      --  find the root.
+
+      DT_Ptr_Typ := Typ;
+      while Present (Parent_Subtype (DT_Ptr_Typ)) loop
+         DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
+      end loop;
+
+      DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+
+      if Present (Conc_Typ) then
+         --  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)));
+      end if;
+
+      --  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, Stmts);
+
+      if Present (Conc_Typ) then
+
+         --  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);
+
+         --  where 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;
+
+      --  Null implementation for limited tagged types
+
+      else
+         Append_To (Stmts,
+           Make_Null_Statement (Loc));
+      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);
+      Params : constant List_Id    := New_List;
+
+   begin
+      --  "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);
+
+      return
+        Make_Procedure_Specification (Loc,
+          Defining_Unit_Name =>
+            Make_Defining_Identifier (Loc, Name_uDisp_Conditional_Select),
+          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;
+      DT_Ptr_Typ : Entity_Id;
+
+   begin
+      --  Typ may be a derived type, climb the derivation chain in order to
+      --  find the root.
+
+      DT_Ptr_Typ := Typ;
+      while Present (Parent_Subtype (DT_Ptr_Typ)) loop
+         DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
+      end loop;
+
+      DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_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 =>
+            No_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);
+      Params : constant List_Id    := New_List;
+
+   begin
+      --  "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);
+
+      return
+        Make_Procedure_Specification (Loc,
+           Defining_Unit_Name =>
+             Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind),
+           Parameter_Specifications =>
+             Params);
+   end Make_Disp_Get_Prim_Op_Kind_Spec;
+
+   -----------------------------
+   -- Make_Disp_Select_Tables --
+   -----------------------------
+
+   function Make_Disp_Select_Tables
+     (Typ : Entity_Id) return List_Id
+   is
+      Assignments : constant List_Id    := New_List;
+      DT_Ptr      : Entity_Id;
+      DT_Ptr_Typ  : Entity_Id;
+      Index       : Uint                := Uint_1;
+      Loc         : constant Source_Ptr := Sloc (Typ);
+      Prim        : Entity_Id;
+      Prim_Als    : Entity_Id;
+      Prim_Elmt   : Elmt_Id;
+      Prim_Pos    : Uint;
+
+   begin
+      pragma Assert (Present (Primitive_Operations (Typ)));
+
+      --  Typ may be a derived type, climb the derivation chain in order to
+      --  find the root.
+
+      DT_Ptr_Typ := Typ;
+      while Present (Parent_Subtype (DT_Ptr_Typ)) loop
+         DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
+      end loop;
+
+      DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+
+      Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+      while Present (Prim_Elmt) loop
+         Prim := Node (Prim_Elmt);
+
+         --  Retrieve the root of the alias chain
+
+         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;
+
+         --  We either have a procedure or a wrapper. Set the primitive
+         --  operation kind for both cases and set the entry index for
+         --  wrappers.
+
+         if Ekind (Prim) = E_Procedure
+           and then Present (Prim_Als)
+           and then Is_Primitive_Wrapper (Prim_Als)
+         then
+            Prim_Pos := DT_Position (Prim);
+
+            --  Generate:
+            --    set_prim_op_kind (<tag>, <position>, <kind>);
+
+            Append_To (Assignments,
+              Make_DT_Access_Action (Typ,
+                Action =>
+                  Set_Prim_Op_Kind,
+                Args =>
+                  New_List (
+                    Unchecked_Convert_To (RTE (RE_Tag),
+                      New_Reference_To (DT_Ptr, Loc)),
+                    Make_Integer_Literal (Loc, Prim_Pos),
+                    Prim_Op_Kind (Prim, Typ))));
+
+            --  The wrapped entity of the alias is an entry
+
+            if Ekind (Wrapped_Entity (Prim_Als)) = E_Entry then
+               --  Generate:
+               --    set_entry_index (<tag>, <position>, <index>);
+
+               Append_To (Assignments,
+                 Make_DT_Access_Action (Typ,
+                   Action =>
+                     Set_Entry_Index,
+                   Args =>
+                     New_List (
+                       Unchecked_Convert_To (RTE (RE_Tag),
+                         New_Reference_To (DT_Ptr, Loc)),
+                       Make_Integer_Literal (Loc, Prim_Pos),
+                       Make_Integer_Literal (Loc, Index))));
+
+               Index := Index + 1;
+            end if;
+         end if;
+
+         Next_Elmt (Prim_Elmt);
+      end loop;
+
+      return Assignments;
+   end Make_Disp_Select_Tables;
+
+   ---------------------------------
+   -- 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;
+      DT_Ptr_Typ : Entity_Id;
+      Stmts      : constant List_Id      := New_List;
+
+   begin
+      if Is_Concurrent_Record_Type (Typ) then
+         Conc_Typ := Corresponding_Concurrent_Type (Typ);
+      end if;
+
+      --  Typ may be a derived type, climb the derivation chain in order to
+      --  find the root.
+
+      DT_Ptr_Typ := Typ;
+      while Present (Parent_Subtype (DT_Ptr_Typ)) loop
+         DT_Ptr_Typ := Parent_Subtype (DT_Ptr_Typ);
+      end loop;
+
+      DT_Ptr := Node (First_Elmt (Access_Disp_Table (DT_Ptr_Typ)));
+
+      if Present (Conc_Typ) then
+
+         --  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)));
+      end if;
+
+      --  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, Stmts);
+
+      if Present (Conc_Typ) then
+
+         --  Generate:
+         --    I := get_entry_index (tag! (<type>VP), S);
+
+         --  where 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;
+
+      --  Null implementation for limited tagged types
+
+      else
+         Append_To (Stmts,
+           Make_Null_Statement (Loc));
+      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);
+      Params : constant List_Id    := New_List;
+
+   begin
+      --  "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);
+
+      return
+        Make_Procedure_Specification (Loc,
+          Defining_Unit_Name =>
+            Make_Defining_Identifier (Loc, Name_uDisp_Timed_Select),
+          Parameter_Specifications =>
+            Params);
+   end Make_Disp_Timed_Select_Spec;
+
    -----------------------------------
    -- Original_View_In_Visible_Part --
    -----------------------------------
@@ -1989,6 +3310,86 @@ package body Exp_Disp is
         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 := Prim;
+
+   begin
+      --  Retrieve the original primitive operation
+
+      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);
+
+         --  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 --
    -------------------------
@@ -2020,6 +3421,7 @@ package body Exp_Disp is
 
       procedure Validate_Position (Prim : Entity_Id) is
          Prim_Elmt : Elmt_Id;
+
       begin
          Prim_Elmt :=  First_Elmt (Primitive_Operations (Typ));
          while Present (Prim_Elmt)
@@ -2043,8 +3445,41 @@ package body Exp_Disp is
                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;
@@ -2096,9 +3531,10 @@ package body Exp_Disp is
                --  Get the slot from the parent subprogram if any
 
                declare
-                  H : Entity_Id := Homonym (Prim);
+                  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
@@ -2129,7 +3565,7 @@ package body Exp_Disp is
          --  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)
+         --  allowed).
 
          if DT_Entry_Count (The_Tag) = No_Uint
            or else not Is_CPP_Class (Typ)
@@ -2142,7 +3578,7 @@ package body Exp_Disp is
          end if;
 
          --  Check that Positions are not duplicate nor outside the range of
-         --  the Vtable
+         --  the Vtable.
 
          declare
             Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag));
@@ -2175,13 +3611,19 @@ package body Exp_Disp is
             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 a-tags.ad?)
+      --  in Ada.Tags).
 
       else
          --  First stage: Set the DTC entity of all the primitive operations
@@ -2190,7 +3632,6 @@ package body Exp_Disp is
 
          Prim_Elmt  := First_Prim;
          Count_Prim := 0;
-
          while Present (Prim_Elmt) loop
             Count_Prim := Count_Prim + 1;
             Prim       := Node (Prim_Elmt);
@@ -2218,16 +3659,17 @@ package body Exp_Disp is
          end loop;
 
          declare
-            Fixed_Prim : array (Int range 0 .. 10 + Parent_EC + Count_Prim)
+            Fixed_Prim : array (Int range 0 .. Default_Prim_Op_Count +
+                                  Parent_EC + Count_Prim)
                            of Boolean := (others => False);
+
             E : Entity_Id;
 
          begin
             --  Second stage: Register fixed entries
 
-            Nb_Prim   := 10;
+            Nb_Prim   := Default_Prim_Op_Count;
             Prim_Elmt := First_Prim;
-
             while Present (Prim_Elmt) loop
                Prim := Node (Prim_Elmt);
 
@@ -2287,13 +3729,11 @@ package body Exp_Disp is
                   --  traversing the chain. This is required to properly
                   --  handling renamed primitives
 
-                  if Present (Alias (E)) then
                   while Present (Alias (E)) loop
                      E   := Alias (E);
                      Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
                   end loop;
                end if;
-               end if;
 
                Next_Elmt (Prim_Elmt);
             end loop;
@@ -2369,12 +3809,20 @@ package body Exp_Disp is
             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);
 
@@ -2473,10 +3921,6 @@ package body Exp_Disp is
             null;
          end if;
       end if;
-
-      if Debug_Flag_ZZ then
-         Write_DT (Typ);
-      end if;
    end Set_All_DT_Position;
 
    -----------------------------
@@ -2546,7 +3990,7 @@ package body Exp_Disp is
       if not (Typ in First_Node_Id .. Last_Node_Id)
         or else not Is_Tagged_Type (Typ)
       then
-         Write_Str ("wrong usage: write_dt must be used with tagged types");
+         Write_Str ("wrong usage: Write_DT must be used with tagged types");
          Write_Eol;
          return;
       end if;

gcc/ada/exp_disp.ads

@@ -30,14 +30,26 @@
 with Types; use Types;
 package Exp_Disp is
 
+   --  Number of predefined primitive operations added by the Expander
+   --  for a tagged type. If more predefined primitive operations are
+   --  added, the following items must be changed:
+
+   --    Ada.Tags.Defailt_Prim_Op_Count    - indirect use
+   --    Exp_Disp.Default_Prim_Op_Position - indirect use
+   --    Exp_Disp.Set_All_DT_Position      - direct   use
+
+   Default_Prim_Op_Count : constant Int := 14;
+
    type DT_Access_Action is
       (CW_Membership,
        IW_Membership,
        DT_Entry_Size,
        DT_Prologue_Size,
        Get_Access_Level,
+       Get_Entry_Index,
        Get_External_Tag,
        Get_Prim_Op_Address,
+       Get_Prim_Op_Kind,
        Get_RC_Offset,
        Get_Remotely_Callable,
        Inherit_DT,
@@ -45,15 +57,42 @@ package Exp_Disp is
        Register_Interface_Tag,
        Register_Tag,
        Set_Access_Level,
+       Set_Entry_Index,
        Set_Expanded_Name,
        Set_External_Tag,
        Set_Prim_Op_Address,
+       Set_Prim_Op_Kind,
        Set_RC_Offset,
        Set_Remotely_Callable,
        Set_TSD,
        TSD_Entry_Size,
        TSD_Prologue_Size);
 
+   procedure Expand_Dispatching_Call (Call_Node : Node_Id);
+   --  Expand the call to the operation through the dispatch table and perform
+   --  the required tag checks when appropriate. For CPP types the call is
+   --  done through the Vtable (tag checks are not relevant)
+
+   procedure Expand_Interface_Actuals    (Call_Node : Node_Id);
+   --  Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide
+   --  interfaces to reference the interface tag of the actual object
+
+   procedure Expand_Interface_Conversion (N : Node_Id);
+   --  Ada 2005 (AI-251): N is a type-conversion node. Reference the base of
+   --  the object to give access to the interface tag associated with the
+   --  secondary dispatch table
+
+   function Expand_Interface_Thunk
+     (N           : Node_Id;
+      Thunk_Alias : Node_Id;
+      Thunk_Id    : Entity_Id;
+      Thunk_Tag   : Entity_Id) return Node_Id;
+   --  Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
+   --  generate additional subprograms (thunks) to have a layout compatible
+   --  with the C++ ABI. The thunk modifies the value of the first actual of
+   --  the call (that is, the pointer to the object) before transferring
+   --  control to the target function.
+
    function Fill_DT_Entry
      (Loc          : Source_Ptr;
       Prim         : Entity_Id) return Node_Id;
@@ -69,6 +108,15 @@ package Exp_Disp is
    --  the secondary dispatch table of Prim's controlling type with Thunk_Id's
    --  address.
 
+   function Get_Remotely_Callable (Obj : Node_Id) return Node_Id;
+   --  Return an expression that holds True if the object can be transmitted
+   --  onto another partition according to E.4 (18)
+
+   function Init_Predefined_Interface_Primitives
+     (Typ : Entity_Id) return List_Id;
+   --  Ada 2005 (AI-251): Initialize the entries associated with predefined
+   --  primitives in all the secondary dispatch tables of Typ.
+
    procedure Make_Abstract_Interface_DT
      (AI_Tag          : Entity_Id;
       Acc_Disp_Tables : in out Elist_Id;
@@ -90,45 +138,65 @@ package Exp_Disp is
    --  Expand the declarations for the Dispatch Table (or the Vtable in
    --  the case of type whose ancestor is a CPP_Class)
 
+   function Make_Disp_Asynchronous_Select_Body
+     (Typ : Entity_Id) return Node_Id;
+   --  Ada 2005 (AI-345): Generate the body of the primitive operation of type
+   --  Typ used for dispatching in asynchronous selects.
+
+   function Make_Disp_Asynchronous_Select_Spec
+     (Typ : Entity_Id) return Node_Id;
+   --  Ada 2005 (AI-345): Generate the specification of the primitive operation
+   --  of type Typ used for dispatching in asynchronous selects.
+
+   function Make_Disp_Conditional_Select_Body
+     (Typ : Entity_Id) return Node_Id;
+   --  Ada 2005 (AI-345): Generate the body of the primitive operation of type
+   --  Typ used for dispatching in conditional selects.
+
+   function Make_Disp_Conditional_Select_Spec
+     (Typ : Entity_Id) return Node_Id;
+   --  Ada 2005 (AI-345): Generate the specification of the primitive operation
+   --  of type Typ used for dispatching in conditional selects.
+
+   function Make_Disp_Get_Prim_Op_Kind_Body
+     (Typ : Entity_Id) return Node_Id;
+   --  Ada 2005 (AI-345): Generate the body of the primitive operation of type
+   --  Typ used for retrieving the callable entity kind during dispatching in
+   --  asynchronous selects.
+
+   function Make_Disp_Get_Prim_Op_Kind_Spec
+     (Typ : Entity_Id) return Node_Id;
+   --  Ada 2005 (AI-345): Generate the specification of the primitive operation
+   --  of the type Typ use for retrieving the callable entity kind during
+   --  dispatching in asynchronous selects.
+
+   function Make_Disp_Select_Tables
+     (Typ : Entity_Id) return List_Id;
+   --  Ada 2005 (AI-345): Populate the two auxiliary tables in the TSD of Typ
+   --  used for dispatching in asynchronous, conditional and timed selects.
+   --  Generate code to set the primitive operation kinds and entry indices
+   --  of primitive operations and primitive wrappers.
+
+   function Make_Disp_Timed_Select_Body
+     (Typ : Entity_Id) return Node_Id;
+   --  Ada 2005 (AI-345): Generate the body of the primitive operation of type
+   --  Typ used for dispatching in timed selects.
+
+   function Make_Disp_Timed_Select_Spec
+     (Typ : Entity_Id) return Node_Id;
+   --  Ada 2005 (AI-345): Generate the specification of the primitive operation
+   --  of type Typ used for dispatching in timed selects.
+
    procedure Set_All_DT_Position (Typ : Entity_Id);
    --  Set the DT_Position field for each primitive operation. In the CPP
    --  Class case check that no pragma CPP_Virtual is missing and that the
    --  DT_Position are coherent
 
-   procedure Expand_Dispatching_Call (Call_Node : Node_Id);
-   --  Expand the call to the operation through the dispatch table and perform
-   --  the required tag checks when appropriate. For CPP types the call is
-   --  done through the Vtable (tag checks are not relevant)
-
-   procedure Expand_Interface_Actuals    (Call_Node : Node_Id);
-   --  Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide
-   --  interfaces to reference the interface tag of the actual object
-
-   procedure Expand_Interface_Conversion (N : Node_Id);
-   --  Ada 2005 (AI-251): N is a type-conversion node. Reference the base of
-   --  the object to give access to the interface tag associated with the
-   --  secondary dispatch table
-
-   function Expand_Interface_Thunk
-     (N           : Node_Id;
-      Thunk_Alias : Node_Id;
-      Thunk_Id    : Entity_Id;
-      Iface_Tag   : Entity_Id) return Node_Id;
-   --  Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
-   --  generate additional subprograms (thunks) to have a layout compatible
-   --  with the C++ ABI. The thunk modifies the value of the first actual of
-   --  the call (that is, the pointer to the object) before transferring
-   --  control to the target function.
-
    procedure Set_Default_Constructor (Typ : Entity_Id);
    --  Typ is a CPP_Class type. Create the Init procedure of that type to
    --  be the default constructor (i.e. the function returning this type,
    --  having a pragma CPP_Constructor and no parameter)
 
-   function Get_Remotely_Callable (Obj : Node_Id) return Node_Id;
-   --  Return an expression that holds True if the object can be transmitted
-   --  onto another partition according to E.4 (18)
-
    procedure Write_DT (Typ : Entity_Id);
    pragma Export (Ada, Write_DT);
    --  Debugging procedure (to be called within gdb)

gcc/ada/exp_util.adb

@@ -31,8 +31,6 @@ with Elists;   use Elists;
 with Errout;   use Errout;
 with Exp_Aggr; use Exp_Aggr;
 with Exp_Ch7;  use Exp_Ch7;
-with Exp_Ch11; use Exp_Ch11;
-with Exp_Tss;  use Exp_Tss;
 with Hostparm; use Hostparm;
 with Inline;   use Inline;
 with Itypes;   use Itypes;
@@ -49,7 +47,6 @@ with Sem_Eval; use Sem_Eval;
 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 Stringt;  use Stringt;
@@ -685,7 +682,7 @@ package body Exp_Util is
       Spec := Make_Function_Specification (Loc,
         Defining_Unit_Name =>
           Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
-        Subtype_Mark => New_Occurrence_Of (Standard_String, Loc));
+        Result_Definition => New_Occurrence_Of (Standard_String, Loc));
 
       --  Calls to 'Image use the secondary stack, which must be cleaned
       --  up after the task name is built.
@@ -1278,6 +1275,13 @@ package body Exp_Util is
       then
          null;
 
+      --  Nothing to be done if the type of the expression is limited, because
+      --  in this case the expression cannot be copied, and its use can only
+      --  be by reference and there is no need for the actual subtype.
+
+      elsif Is_Limited_Type (Exp_Typ) then
+         null;
+
       else
          Remove_Side_Effects (Exp);
          Rewrite (Subtype_Indic,
@@ -1409,7 +1413,7 @@ package body Exp_Util is
            and then Present (Abstract_Interfaces (Typ))
            and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
          then
-            --  Skip the tag associated with the primary table.
+            --  Skip the tag associated with the primary table
 
             pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
             AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
@@ -1449,12 +1453,21 @@ package body Exp_Util is
 
       --  Handle task and protected types implementing interfaces
 
-      if Ekind (Typ) = E_Protected_Type
-        or else Ekind (Typ) = E_Task_Type
-      then
+      if Is_Concurrent_Type (Typ) then
          Typ := Corresponding_Record_Type (Typ);
       end if;
 
+      if Is_Class_Wide_Type (Typ) then
+         Typ := Etype (Typ);
+      end if;
+
+      --  Handle entities from the limited view
+
+      if Ekind (Typ) = E_Incomplete_Type then
+         pragma Assert (Present (Non_Limited_View (Typ)));
+         Typ := Non_Limited_View (Typ);
+      end if;
+
       Find_Tag (Typ);
       pragma Assert (Found);
       return AI_Tag;
@@ -1729,6 +1742,68 @@ package body Exp_Util is
       return Count;
    end Homonym_Number;
 
+   ----------------------------------
+   -- Implements_Limited_Interface --
+   ----------------------------------
+
+   function Implements_Limited_Interface (Typ : Entity_Id) return Boolean is
+      function Contains_Limited_Interface
+        (Ifaces : Elist_Id) return Boolean;
+      --  Given a list of interfaces, determine whether one of them is limited
+
+      --------------------------------
+      -- Contains_Limited_Interface --
+      --------------------------------
+
+      function Contains_Limited_Interface
+        (Ifaces : Elist_Id) return Boolean
+      is
+         Iface_Elmt : Elmt_Id;
+
+      begin
+         if not Present (Ifaces) then
+            return False;
+         end if;
+
+         Iface_Elmt := First_Elmt (Ifaces);
+
+         while Present (Iface_Elmt) loop
+            if Is_Limited_Record (Node (Iface_Elmt)) then
+               return True;
+            end if;
+
+            Iface_Elmt := Next_Elmt (Iface_Elmt);
+         end loop;
+
+         return False;
+      end Contains_Limited_Interface;
+
+   --  Start of processing for Implements_Limited_Interface
+
+   begin
+      --  Typ is a derived type and may implement a limited interface
+      --  through its parent subtype. Check the parent subtype as well
+      --  as any interfaces explicitly implemented at this level.
+
+      if Ekind (Typ) = E_Record_Type
+        and then Present (Parent_Subtype (Typ))
+      then
+         return Contains_Limited_Interface (Abstract_Interfaces (Typ))
+           or else Implements_Limited_Interface (Parent_Subtype (Typ));
+
+      --  Typ is an abstract type derived from some interface
+
+      elsif Is_Abstract (Typ) then
+         return Is_Interface (Etype (Typ))
+           and then Is_Limited_Record (Etype (Typ));
+
+      --  Typ may directly implement some interface
+
+      else
+         return Contains_Limited_Interface (Abstract_Interfaces (Typ));
+      end if;
+   end Implements_Limited_Interface;
+
    ------------------------------
    -- In_Unconditional_Context --
    ------------------------------
@@ -2515,6 +2590,10 @@ package body Exp_Util is
            or else Chars (E) = Name_uAssign
            or else TSS_Name  = TSS_Deep_Adjust
            or else TSS_Name  = TSS_Deep_Finalize
+           or else Chars (E) = Name_uDisp_Asynchronous_Select
+           or else Chars (E) = Name_uDisp_Conditional_Select
+           or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind
+           or else Chars (E) = Name_uDisp_Timed_Select
          then
             return True;
          end if;
@@ -2919,7 +2998,6 @@ package body Exp_Util is
    procedure Kill_Dead_Code (N : Node_Id) is
    begin
       if Present (N) then
-         Remove_Handler_Entries (N);
          Remove_Warning_Messages (N);
 
          --  Recurse into block statements and bodies to process declarations

gcc/ada/exp_util.ads

@@ -410,6 +410,12 @@ package Exp_Util is
    --  chain, counting only entries in the curren scope. If an entity is not
    --  overloaded, the returned number will be one.
 
+   function Implements_Limited_Interface (Typ : Entity_Id) return Boolean;
+   --  Ada 2005 (AI-345): Determine whether Typ implements some limited
+   --  interface. The interface may be of limited, protected, synchronized
+   --  or taks kind. Typ may also be derived from a type that implements a
+   --  limited interface.
+
    function Inside_Init_Proc return Boolean;
    --  Returns True if current scope is within an init proc
 

gcc/ada/rtsfind.ads

@@ -108,7 +108,7 @@ package Rtsfind is
       --  package see declarations in the runtime entity table below.
 
       RTU_Null,
-      --  Used as a null entry. Will cause an error if referenced.
+      --  Used as a null entry. Will cause an error if referenced
 
       --  Children of Ada
 
@@ -199,7 +199,6 @@ package Rtsfind is
       System_Compare_Array_Unsigned_64,
       System_Compare_Array_Unsigned_8,
       System_Exception_Table,
-      System_Exceptions,
       System_Exn_Int,
       System_Exn_LLF,
       System_Exn_LLI,
@@ -492,21 +491,33 @@ package Rtsfind is
      RE_DT_Prologue_Size,                -- Ada.Tags
      RE_External_Tag,                    -- Ada.Tags
      RE_Get_Access_Level,                -- Ada.Tags
+     RE_Get_Entry_Index,                 -- Ada.Tags
      RE_Get_External_Tag,                -- Ada.Tags
      RE_Get_Prim_Op_Address,             -- Ada.Tags
+     RE_Get_Prim_Op_Kind,                -- Ada.Tags
      RE_Get_RC_Offset,                   -- Ada.Tags
      RE_Get_Remotely_Callable,           -- Ada.Tags
      RE_Inherit_DT,                      -- Ada.Tags
      RE_Inherit_TSD,                     -- Ada.Tags
      RE_Internal_Tag,                    -- Ada.Tags
      RE_Is_Descendant_At_Same_Level,     -- Ada.Tags
+     RE_POK_Function,                    -- Ada.Tags
+     RE_POK_Procedure,                   -- Ada.Tags
+     RE_POK_Protected_Entry,             -- Ada.Tags
+     RE_POK_Protected_Function,          -- Ada.Tags
+     RE_POK_Protected_Procedure,         -- Ada.Tags
+     RE_POK_Task_Entry,                  -- Ada.Tags
+     RE_POK_Task_Procedure,              -- Ada.Tags
+     RE_Prim_Op_Kind,                    -- Ada.Tags
      RE_Register_Interface_Tag,          -- Ada.Tags
      RE_Register_Tag,                    -- Ada.Tags
      RE_Set_Access_Level,                -- Ada.Tags
+     RE_Set_Entry_Index,                 -- Ada.Tags
      RE_Set_Expanded_Name,               -- Ada.Tags
      RE_Set_External_Tag,                -- Ada.Tags
      RE_Set_Offset_To_Top,               -- Ada.Tags
      RE_Set_Prim_Op_Address,             -- Ada.Tags
+     RE_Set_Prim_Op_Kind,                -- Ada.Tags
      RE_Set_RC_Offset,                   -- Ada.Tags
      RE_Set_Remotely_Callable,           -- Ada.Tags
      RE_Set_TSD,                         -- Ada.Tags
@@ -639,20 +650,6 @@ package Rtsfind is
 
      RE_Register_Exception,              -- System.Exception_Table
 
-     RE_All_Others_Id,                   -- System.Exceptions
-     RE_Handler_Record,                  -- System.Exceptions
-     RE_Handler_Record_Ptr,              -- System.Exceptions
-     RE_Others_Id,                       -- System.Exceptions
-     RE_Subprogram_Descriptor,           -- System.Exceptions
-     RE_Subprogram_Descriptor_0,         -- System.Exceptions
-     RE_Subprogram_Descriptor_1,         -- System.Exceptions
-     RE_Subprogram_Descriptor_2,         -- System.Exceptions
-     RE_Subprogram_Descriptor_3,         -- System.Exceptions
-     RE_Subprogram_Descriptor_List,      -- System.Exceptions
-     RE_Subprogram_Descriptor_Ptr,       -- System.Exceptions
-     RE_Subprogram_Descriptors_Record,   -- System.Exceptions
-     RE_Subprogram_Descriptors_Ptr,      -- System.Exceptions
-
      RE_Exn_Integer,                     -- System.Exn_Int
 
      RE_Exn_Long_Long_Float,             -- System.Exn_LLF
@@ -1421,6 +1418,10 @@ package Rtsfind is
      RE_Lt_F,                            -- System.Vax_Float_Operations
      RE_Lt_G,                            -- System.Vax_Float_Operations
 
+     RE_Valid_D,                         -- System.Vax_Float_Operations
+     RE_Valid_F,                         -- System.Vax_Float_Operations
+     RE_Valid_G,                         -- System.Vax_Float_Operations
+
      RE_Version_String,                  -- System.Version_Control
      RE_Get_Version_String,              -- System.Version_Control
 
@@ -1599,21 +1600,33 @@ package Rtsfind is
      RE_DT_Prologue_Size                 => Ada_Tags,
      RE_External_Tag                     => Ada_Tags,
      RE_Get_Access_Level                 => Ada_Tags,
+     RE_Get_Entry_Index                  => Ada_Tags,
      RE_Get_External_Tag                 => Ada_Tags,
      RE_Get_Prim_Op_Address              => Ada_Tags,
+     RE_Get_Prim_Op_Kind                 => Ada_Tags,
      RE_Get_RC_Offset                    => Ada_Tags,
      RE_Get_Remotely_Callable            => Ada_Tags,
      RE_Inherit_DT                       => Ada_Tags,
      RE_Inherit_TSD                      => Ada_Tags,
      RE_Internal_Tag                     => Ada_Tags,
      RE_Is_Descendant_At_Same_Level      => Ada_Tags,
+     RE_POK_Function                     => Ada_Tags,
+     RE_POK_Procedure                    => Ada_Tags,
+     RE_POK_Protected_Entry              => Ada_Tags,
+     RE_POK_Protected_Function           => Ada_Tags,
+     RE_POK_Protected_Procedure          => Ada_Tags,
+     RE_POK_Task_Entry                   => Ada_Tags,
+     RE_POK_Task_Procedure               => Ada_Tags,
+     RE_Prim_Op_Kind                     => Ada_Tags,
      RE_Register_Interface_Tag           => Ada_Tags,
      RE_Register_Tag                     => Ada_Tags,
      RE_Set_Access_Level                 => Ada_Tags,
+     RE_Set_Entry_Index                  => Ada_Tags,
      RE_Set_Expanded_Name                => Ada_Tags,
      RE_Set_External_Tag                 => Ada_Tags,
      RE_Set_Offset_To_Top                => Ada_Tags,
      RE_Set_Prim_Op_Address              => Ada_Tags,
+     RE_Set_Prim_Op_Kind                 => Ada_Tags,
      RE_Set_RC_Offset                    => Ada_Tags,
      RE_Set_Remotely_Callable            => Ada_Tags,
      RE_Set_TSD                          => Ada_Tags,
@@ -1744,20 +1757,6 @@ package Rtsfind is
 
      RE_Register_Exception               => System_Exception_Table,
 
-     RE_All_Others_Id                    => System_Exceptions,
-     RE_Handler_Record                   => System_Exceptions,
-     RE_Handler_Record_Ptr               => System_Exceptions,
-     RE_Others_Id                        => System_Exceptions,
-     RE_Subprogram_Descriptor            => System_Exceptions,
-     RE_Subprogram_Descriptor_0          => System_Exceptions,
-     RE_Subprogram_Descriptor_1          => System_Exceptions,
-     RE_Subprogram_Descriptor_2          => System_Exceptions,
-     RE_Subprogram_Descriptor_3          => System_Exceptions,
-     RE_Subprogram_Descriptor_List       => System_Exceptions,
-     RE_Subprogram_Descriptor_Ptr        => System_Exceptions,
-     RE_Subprogram_Descriptors_Record    => System_Exceptions,
-     RE_Subprogram_Descriptors_Ptr       => System_Exceptions,
-
      RE_Exn_Integer                      => System_Exn_Int,
 
      RE_Exn_Long_Long_Float              => System_Exn_LLF,
@@ -2525,6 +2524,10 @@ package Rtsfind is
      RE_Lt_F                             => System_Vax_Float_Operations,
      RE_Lt_G                             => System_Vax_Float_Operations,
 
+     RE_Valid_D                          => System_Vax_Float_Operations,
+     RE_Valid_F                          => System_Vax_Float_Operations,
+     RE_Valid_G                          => System_Vax_Float_Operations,
+
      RE_Version_String                   => System_Version_Control,
      RE_Get_Version_String               => System_Version_Control,
 
@@ -2805,7 +2808,7 @@ package Rtsfind is
    --  not mean that an attempt to load it subsequently would fail.
 
    procedure Set_RTU_Loaded (N : Node_Id);
-   --  Register the predefined unit N as already loaded.
+   --  Register the predefined unit N as already loaded
 
    procedure Text_IO_Kludge (Nam : Node_Id);
    --  In Ada 83, and hence for compatibility in Ada 9X, package Text_IO has

gcc/ada/sem_ch9.adb

@@ -1924,8 +1924,25 @@ package body Sem_Ch9 is
         and then Nkind (Trigger) /= N_Delay_Relative_Statement
         and then Nkind (Trigger) /= N_Entry_Call_Statement
       then
+         if Ada_Version < Ada_05 then
             Error_Msg_N
              ("triggering statement must be delay or entry call", Trigger);
+
+         --  Ada 2005 (AI-345): If a procedure_call_statement is used
+         --  for a procedure_or_entry_call, the procedure_name or pro-
+         --  cedure_prefix of the procedure_call_statement shall denote
+         --  an entry renamed by a procedure, or (a view of) a primitive
+         --  subprogram of a limited interface whose first parameter is
+         --  a controlling parameter.
+
+         elsif Nkind (Trigger) = N_Procedure_Call_Statement
+           and then not Is_Renamed_Entry (Entity (Name (Trigger)))
+           and then not Is_Controlling_Limited_Procedure
+                          (Entity (Name (Trigger)))
+         then
+            Error_Msg_N ("triggering statement must be delay, procedure " &
+                         "or entry call", Trigger);
+         end if;
       end if;
 
       if Is_Non_Empty_List (Statements (N)) then
@@ -2211,8 +2228,8 @@ package body Sem_Ch9 is
                     and then Matches_Prefixed_View_Profile (Ifaces,
                                Parameter_Specifications (Spec),
                                Parameter_Specifications (Parent (Hom)))
-                    and then Etype (Subtype_Mark (Spec)) =
-                             Etype (Subtype_Mark (Parent (Hom)))
+                    and then Etype (Result_Definition (Spec)) =
+                             Etype (Result_Definition (Parent (Hom)))
                   then
                      Overrides := True;
                      exit;

gcc/ada/uintp.ads

@@ -64,7 +64,10 @@ package Uintp is
    Uint_8   : constant Uint;
    Uint_9   : constant Uint;
    Uint_10  : constant Uint;
+   Uint_11  : constant Uint;
    Uint_12  : constant Uint;
+   Uint_13  : constant Uint;
+   Uint_14  : constant Uint;
    Uint_15  : constant Uint;
    Uint_16  : constant Uint;
    Uint_24  : constant Uint;
@@ -430,7 +433,10 @@ private
    Uint_8   : constant Uint := Uint (Uint_Direct_Bias + 8);
    Uint_9   : constant Uint := Uint (Uint_Direct_Bias + 9);
    Uint_10  : constant Uint := Uint (Uint_Direct_Bias + 10);
+   Uint_11  : constant Uint := Uint (Uint_Direct_Bias + 11);
    Uint_12  : constant Uint := Uint (Uint_Direct_Bias + 12);
+   Uint_13  : constant Uint := Uint (Uint_Direct_Bias + 13);
+   Uint_14  : constant Uint := Uint (Uint_Direct_Bias + 14);
    Uint_15  : constant Uint := Uint (Uint_Direct_Bias + 15);
    Uint_16  : constant Uint := Uint (Uint_Direct_Bias + 16);
    Uint_24  : constant Uint := Uint (Uint_Direct_Bias + 24);