Patchwork [Ada] Implementation of Ada 2012 AI05-0030: Requeue on synchronized interfaces

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 8, 2010, 10:09 a.m.
Message ID <20101008100913.GA22275@adacore.com>
Download mbox | patch
Permalink /patch/67156/
State New
Headers show

Comments

Arnaud Charlet - Oct. 8, 2010, 10:09 a.m.
This patch integrates the new syntax, legality rules, static semantics, name
resolution rules and runtime mechanism associated with dispatching requeue
statements where the procedure_or_entry_NAME denotes a primitive procedure of a
synchronized interface.

-------------
-- Sources --
-------------

--  by_any.ads

package By_Any is
   type Synch_Iface is synchronized interface;
   procedure A
     (Obj : in out Synch_Iface;
      Tar : in out Synch_Iface'Class;
      Int : Integer) is abstract;
   pragma Implemented (A, By_Any);

   protected type Prot_Typ is new Synch_Iface with
      procedure A (Tar : in out Synch_Iface'Class; Int : Integer);
   end Prot_Typ;

   task type Task_Typ is new Synch_Iface with
      entry A (Tar : in out Synch_Iface'Class; Int : Integer);
   end Task_Typ;

   protected type Prot_Requeuer is
      entry Do_Requeue (Tar : in out Synch_Iface'Class; Int : Integer);
   end Prot_Requeuer;
end By_Any;

--  by_any.adb

with Ada.Text_IO; use Ada.Text_IO;
package body By_Any is
   protected body Prot_Typ is
      procedure A (Tar : in out Synch_Iface'Class; Int : Integer) is
      begin
         Put_Line ("  Prot_Typ.A" & Int'Img);
      end A;
   end Prot_Typ;

   task body Task_Typ is
   begin
      accept A (Tar : in out Synch_Iface'Class; Int : Integer) do
         Put_Line ("  Task_Typ.A" & Int'Img);
      end A;
   end Task_Typ;

   protected body Prot_Requeuer is
      entry Do_Requeue
        (Tar : in out Synch_Iface'Class;
         Int : Integer) when True
      is
      begin
         Put_Line ("  Prot_Requeuer.Do_Requeue");
         requeue Tar.A;
      end Do_Requeue;
   end Prot_Requeuer;
end By_Any;

--  main.adb

with Ada.Text_IO; use Ada.Text_IO;
with By_Any;      use By_Any;
procedure Main is
begin
   declare
      Obj      : Prot_Typ;
      Prot_Req : Prot_Requeuer;
   begin
      Put_Line ("Requeue protected to protected");
      Prot_Req.Do_Requeue (Obj, 1);
   end;

   declare
      Obj      : Task_Typ;
      Prot_Req : Prot_Requeuer;
   begin
      Put_Line ("Requeue protected to task");
      Prot_Req.Do_Requeue (Obj, 2);
   end;
end Main;

-----------------
-- Compilation --
-----------------

gnatmake -q -gnat12 main.adb

--------------------------
-- Execution and output --
--------------------------

./main
Requeue protected to protected
  Prot_Requeuer.Do_Requeue
  Prot_Typ.A 1
Requeue protected to task
  Prot_Requeuer.Do_Requeue
  Task_Typ.A 2

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-10-08  Hristian Kirtchev  <kirtchev@adacore.com>

	* einfo.adb: Flag 232 (formerly Implemented_By_Entry) is now unused.
	(Implemented_By_Entry): Removed.
	(Set_Implemented_By_Entry): Removed.
	(Write_Entity_Flags): Remove the output for Implemented_By_Entry.
	* einfo.ads: Remove flag Implemented_By_Entry and its usage in entities.
	(Implemented_By_Entry): Removed along with its associated pragma Inline.
	(Set_Implemented_By_Entry): Removed along with its associated pragma
	Inline.
	* exp_ch9.adb: Alphabetize with and use clauses of Exp_Ch9.
	(Build_Dispatching_Call_Equivalent): New routine.
	(Build_Dispatching_Requeue): New routine.
	(Build_Dispatching_Requeue_To_Any): New routine.
	(Build_Normal_Requeue): New routine.
	(Build_Skip_Statement): New routine.
	(Expand_N_Requeue_Statement): Rewritten. The logic has been split into
	several subroutines.
	* par-prag.adb: Replace Pragma_Implemented_By_Entry by
	Pragma_Implemented.
	* sem_ch3.adb (Check_Abstract_Overriding): Perform checks concerning
	pragma Implemented.
	(Check_Pragma_Implemented): New routines.
	(Inherit_Pragma_Implemented): New routine.
	* sem_ch9.adb (Analyze_Requeue): Update the predicate which detects a
	dispatching requeue.
	* sem_prag.adb: Update array Sig_Flags by removing Implemented_By_Entry
	and adding Implemented.
	(Ada_2012_Pragma): New routine.
	(Analyze_Pragma, case Implemented): Perform all necessary checks
	concerning pragma Implemented and register the pragma as a
	representation item with the procedure_LOCAL_NAME.
	(Analyze_Pragma, case Implemented_By_Entry): Removed.
	* sem_util.adb (Implementation_Kind): New routine.
	* sem_util.ads (Implementation_Kind): New routine.
	* snames.ads-tmpl: Remove Name_Implemented_By_Entry and add
	Name_Implemented. Remove pragma name Pragma_Implemented_By_Entry and
	add Pragma_Implemented. Add special names By_Any, By_Entry and
	By_Protected_Procedure.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 165082)
+++ sem_ch3.adb	(working copy)
@@ -8375,6 +8375,155 @@  package body Sem_Ch3 is
       Subp       : Entity_Id;
       Type_Def   : Node_Id;
 
+      procedure Check_Pragma_Implemented (Subp : Entity_Id);
+      --  Ada 2012 (AI05-0030): Subprogram Subp overrides an interface routine
+      --  which has pragma Implemented already set. Check whether Subp's entity
+      --  kind conforms to the implementation kind of the overridden routine.
+
+      procedure Check_Pragma_Implemented
+        (Subp       : Entity_Id;
+         Iface_Subp : Entity_Id);
+      --  Ada 2012 (AI05-0030): Subprogram Subp overrides interface routine
+      --  Iface_Subp and both entities have pragma Implemented already set on
+      --  them. Check whether the two implementation kinds are conforming.
+
+      procedure Inherit_Pragma_Implemented
+        (Subp       : Entity_Id;
+         Iface_Subp : Entity_Id);
+      --  Ada 2012 (AI05-0030): Interface primitive Subp overrides interface
+      --  subprogram Iface_Subp which has been marked by pragma Implemented.
+      --  Propagate the implementation kind of Iface_Subp to Subp.
+
+      ------------------------------
+      -- Check_Pragma_Implemented --
+      ------------------------------
+
+      procedure Check_Pragma_Implemented (Subp : Entity_Id) is
+         Iface_Alias : constant Entity_Id := Interface_Alias (Subp);
+         Impl_Kind   : constant Name_Id   := Implementation_Kind (Iface_Alias);
+         Contr_Typ   : Entity_Id;
+
+      begin
+         --  Subp must have an alias since it is a hidden entity used to link
+         --  an interface subprogram to its overriding counterpart.
+
+         pragma Assert (Present (Alias (Subp)));
+
+         --  Extract the type of the controlling formal
+
+         Contr_Typ := Etype (First_Formal (Alias (Subp)));
+
+         if Is_Concurrent_Record_Type (Contr_Typ) then
+            Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ);
+         end if;
+
+         --  An interface subprogram whose implementation kind is By_Entry must
+         --  be implemented by an entry.
+
+         if Impl_Kind = Name_By_Entry
+           and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Entry
+         then
+            Error_Msg_Node_2 := Iface_Alias;
+            Error_Msg_NE
+              ("type & must implement abstract subprogram & with an entry",
+               Alias (Subp), Contr_Typ);
+
+         elsif Impl_Kind = Name_By_Protected_Procedure then
+
+            --  An interface subprogram whose implementation kind is By_
+            --  Protected_Procedure cannot be implemented by a primitive
+            --  procedure of a task type.
+
+            if Ekind (Contr_Typ) /= E_Protected_Type then
+               Error_Msg_Node_2 := Contr_Typ;
+               Error_Msg_NE
+                 ("interface subprogram & cannot be implemented by a " &
+                  "primitive procedure of task type &", Alias (Subp),
+                  Iface_Alias);
+
+            --  An interface subprogram whose implementation kind is By_
+            --  Protected_Procedure must be implemented by a procedure.
+
+            elsif Is_Primitive_Wrapper (Alias (Subp))
+              and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Procedure
+            then
+               Error_Msg_Node_2 := Iface_Alias;
+               Error_Msg_NE
+                 ("type & must implement abstract subprogram & with a " &
+                  "procedure", Alias (Subp), Contr_Typ);
+            end if;
+         end if;
+      end Check_Pragma_Implemented;
+
+      ------------------------------
+      -- Check_Pragma_Implemented --
+      ------------------------------
+
+      procedure Check_Pragma_Implemented
+        (Subp       : Entity_Id;
+         Iface_Subp : Entity_Id)
+      is
+         Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp);
+         Subp_Kind  : constant Name_Id := Implementation_Kind (Subp);
+
+      begin
+         --  Ada 2012 (AI05-0030): The implementation kinds of an overridden
+         --  and overriding subprogram are different. In general this is an
+         --  error except when the implementation kind of the overridden
+         --  subprograms is By_Any.
+
+         if Iface_Kind /= Subp_Kind
+           and then Iface_Kind /= Name_By_Any
+         then
+            if Iface_Kind = Name_By_Entry then
+               Error_Msg_N
+                 ("incompatible implementation kind, overridden subprogram " &
+                  "is marked By_Entry", Subp);
+            else
+               Error_Msg_N
+                 ("incompatible implementation kind, overridden subprogram " &
+                  "is marked By_Protected_Procedure", Subp);
+            end if;
+         end if;
+      end Check_Pragma_Implemented;
+
+      --------------------------------
+      -- Inherit_Pragma_Implemented --
+      --------------------------------
+
+      procedure Inherit_Pragma_Implemented
+        (Subp       : Entity_Id;
+         Iface_Subp : Entity_Id)
+      is
+         Iface_Kind : constant Name_Id    := Implementation_Kind (Iface_Subp);
+         Loc        : constant Source_Ptr := Sloc (Subp);
+         Impl_Prag  : Node_Id;
+
+      begin
+         --  Since the implementation kind is stored as a representation item
+         --  rather than a flag, create a pragma node.
+
+         Impl_Prag :=
+           Make_Pragma (Loc,
+             Chars => Name_Implemented,
+             Pragma_Argument_Associations => New_List (
+               Make_Pragma_Argument_Association (Loc,
+                 Expression =>
+                   New_Reference_To (Subp, Loc)),
+
+               Make_Pragma_Argument_Association (Loc,
+                 Expression =>
+                   Make_Identifier (Loc, Iface_Kind))));
+
+         --  The pragma doesn't need to be analyzed because it is internaly
+         --  build. It is safe to directly register it as a rep item since we
+         --  are only interested in the characters of the implementation kind.
+
+         Record_Rep_Item (Subp, Impl_Prag);
+      end Inherit_Pragma_Implemented;
+
+   --  Start of processing for Check_Abstract_Overriding
+
    begin
       Op_List := Primitive_Operations (T);
 
@@ -8584,33 +8733,48 @@  package body Sem_Ch3 is
             end if;
          end if;
 
-         --  Ada 2005 (AI05-0030): Inspect hidden subprograms which provide
-         --  the mapping between interface and implementing type primitives.
-         --  If the interface alias is marked as Implemented_By_Entry, the
-         --  alias must be an entry wrapper.
+         --  Ada 2012 (AI05-0030): Perform some checks related to pragma
+         --  Implemented
 
-         if Ada_Version >= Ada_05
+         --  Subp is an expander-generated procedure which maps an interface
+         --  alias to a protected wrapper. The interface alias is flagged by
+         --  pragma Implemented. Ensure that Subp is a procedure when the
+         --  implementation kind is By_Protected_Procedure or an entry when
+         --  By_Entry.
+
+         if Ada_Version >= Ada_2012
            and then Is_Hidden (Subp)
            and then Present (Interface_Alias (Subp))
-           and then Implemented_By_Entry (Interface_Alias (Subp))
-           and then Present (Alias_Subp)
-           and then
-             (not Is_Primitive_Wrapper (Alias_Subp)
-                or else Ekind (Wrapped_Entity (Alias_Subp)) /= E_Entry)
+           and then Has_Rep_Pragma (Interface_Alias (Subp), Name_Implemented)
          then
-            declare
-               Error_Ent : Entity_Id := T;
+            Check_Pragma_Implemented (Subp);
+         end if;
 
-            begin
-               if Is_Concurrent_Record_Type (Error_Ent) then
-                  Error_Ent := Corresponding_Concurrent_Type (Error_Ent);
-               end if;
+         --  Subp is an interface primitive which overrides another interface
+         --  primitive marked with pragma Implemented.
 
-               Error_Msg_Node_2 := Interface_Alias (Subp);
-               Error_Msg_NE
-                 ("type & must implement abstract subprogram & with an entry",
-                  Error_Ent, Error_Ent);
-            end;
+         if Ada_Version >= Ada_2012
+           and then Is_Overriding_Operation (Subp)
+           and then Present (Overridden_Operation (Subp))
+           and then Has_Rep_Pragma
+                      (Overridden_Operation (Subp), Name_Implemented)
+         then
+            --  If the overriding routine is also marked by Implemented, check
+            --  that the two implementation kinds are conforming.
+
+            if Has_Rep_Pragma (Subp, Name_Implemented) then
+               Check_Pragma_Implemented
+                 (Subp       => Subp,
+                  Iface_Subp => Overridden_Operation (Subp));
+
+            --  Otherwise the overriding routine inherits the implementation
+            --  kind from the overridden subprogram.
+
+            else
+               Inherit_Pragma_Implemented
+                 (Subp       => Subp,
+                  Iface_Subp => Overridden_Operation (Subp));
+            end if;
          end if;
 
          Next_Elmt (Elmt);
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb	(revision 165080)
+++ exp_ch9.adb	(working copy)
@@ -29,8 +29,8 @@  with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
 with Exp_Ch3;  use Exp_Ch3;
-with Exp_Ch11; use Exp_Ch11;
 with Exp_Ch6;  use Exp_Ch6;
+with Exp_Ch11; use Exp_Ch11;
 with Exp_Dbug; use Exp_Dbug;
 with Exp_Disp; use Exp_Disp;
 with Exp_Sel;  use Exp_Sel;
@@ -8310,8 +8310,10 @@  package body Exp_Ch9 is
    --     when all others =>
    --        Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
 
-   --  Ada 2005 (AI05-0030): Dispatching requeue from protected to interface
-   --  class-wide type:
+   --  Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
+   --  marked by pragma Implemented (XXX, By_Entry).
+
+   --  The requeue is inside a protected entry:
 
    --  procedure entE
    --    (O : System.Address;
@@ -8347,10 +8349,9 @@  package body Exp_Ch9 is
    --     end;
    --  end entE;
 
-   --  Ada 2005 (AI05-0030): Dispatching requeue from task to interface
-   --  class-wide type:
+   --  The requeue is inside a task entry:
 
-   --  Accept_Call (E, Ann);
+   --    Accept_Call (E, Ann);
    --     <start of statement sequence for accept statement>
    --     _Disp_Requeue
    --       (<interface class-wide object>,
@@ -8370,63 +8371,159 @@  package body Exp_Ch9 is
    --     when all others =>
    --        Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
 
-   --  Further details on these expansions can be found in Expand_N_Protected_
-   --  Body and Expand_N_Accept_Statement.
+   --  Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
+   --  marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
+   --  statement is replaced by a dispatching call with actual parameters taken
+   --  from the inner-most accept statement or entry body.
+
+   --    Target.Primitive (Param1, ..., ParamN);
+
+   --  Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
+   --  marked by pragma Implemented (XXX, By_Any) or not marked at all.
+
+   --    declare
+   --       S : constant Offset_Index :=
+   --             Get_Offset_Index (Tag (Concval), DT_Position (Ename));
+   --       C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
+
+   --    begin
+   --       if C = POK_Protected_Entry
+   --         or else C = POK_Task_Entry
+   --       then
+   --          <statements for dispatching requeue>
+
+   --       elsif C = POK_Protected_Procedure then
+   --          <dispatching call equivalent>
+
+   --       else
+   --          raise Program_Error;
+   --       end if;
+   --    end;
 
    procedure Expand_N_Requeue_Statement (N : Node_Id) is
-      Loc        : constant Source_Ptr := Sloc (N);
-      Abortable  : Node_Id;
-      Acc_Stat   : Node_Id;
-      Conc_Typ   : Entity_Id;
-      Concval    : Node_Id;
-      Ename      : Node_Id;
-      Index      : Node_Id;
-      Lab_Node   : Node_Id;
-      New_Param  : Node_Id;
-      Old_Typ    : Entity_Id;
-      Params     : List_Id;
-      Rcall      : Node_Id;
-      RTS_Call   : Entity_Id;
-      Self_Param : Node_Id;
-      Skip_Stat  : Node_Id;
+      Loc      : constant Source_Ptr := Sloc (N);
+      Conc_Typ : Entity_Id;
+      Concval  : Node_Id;
+      Ename    : Node_Id;
+      Index    : Node_Id;
+      Old_Typ  : Entity_Id;
+
+      function Build_Dispatching_Call_Equivalent return Node_Id;
+      --  Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
+      --  the form Concval.Ename. It is statically known that Ename is allowed
+      --  to be implemented by a protected procedure. Create a dispatching call
+      --  equivalent of Concval.Ename taking the actual parameters from the
+      --  inner-most accept statement or entry body.
+
+      function Build_Dispatching_Requeue return Node_Id;
+      --  Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
+      --  the form Concval.Ename. It is statically known that Ename is allowed
+      --  to be implemented by a protected or a task entry. Create a call to
+      --  primitive _Disp_Requeue which handles the low-level actions.
+
+      function Build_Dispatching_Requeue_To_Any return Node_Id;
+      --  Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
+      --  the form Concval.Ename. Ename is either marked by pragma Implemented
+      --  (XXX, By_Any) or not marked at all. Create a block which determines
+      --  at runtime whether Ename denotes an entry or a procedure and perform
+      --  the appropriate kind of dispatching select.
+
+      function Build_Normal_Requeue return Node_Id;
+      --  N denotes a non-dispatching requeue statement to either a task or a
+      --  protected entry. Build the appropriate runtime call to perform the
+      --  action.
+
+      function Build_Skip_Statement (Search : Node_Id) return Node_Id;
+      --  For a protected entry, create a return statement to skip the rest of
+      --  the entry body. Otherwise, create a goto statement to skip the rest
+      --  of a task accept statement. The lookup for the enclosing entry body
+      --  or accept statement starts from Search.
 
-   begin
-      Abortable :=
-        New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc);
+      ---------------------------------------
+      -- Build_Dispatching_Call_Equivalent --
+      ---------------------------------------
 
-      --  Extract the components of the entry call
+      function Build_Dispatching_Call_Equivalent return Node_Id is
+         Call_Ent : constant Entity_Id := Entity (Ename);
+         Obj      : constant Node_Id   := Original_Node (Concval);
+         Acc_Ent  : Node_Id;
+         Actuals  : List_Id;
+         Formal   : Node_Id;
+         Formals  : List_Id;
 
-      Extract_Entry (N, Concval, Ename, Index);
-      Conc_Typ := Etype (Concval);
+      begin
+         --  Climb the parent chain looking for the inner-most entry body or
+         --  accept statement.
 
-      --  Examine the scope stack in order to find nearest enclosing protected
-      --  or task type. This will constitute our invocation source.
+         Acc_Ent := N;
+         while Present (Acc_Ent)
+           and then not Nkind_In (Acc_Ent, N_Accept_Statement,
+                                           N_Entry_Body)
+         loop
+            Acc_Ent := Parent (Acc_Ent);
+         end loop;
 
-      Old_Typ := Current_Scope;
-      while Present (Old_Typ)
-        and then not Is_Protected_Type (Old_Typ)
-        and then not Is_Task_Type (Old_Typ)
-      loop
-         Old_Typ := Scope (Old_Typ);
-      end loop;
+         --  A requeue statement should be housed inside an entry body or an
+         --  accept statement at some level. If this is not the case, then the
+         --  tree is malformed.
 
-      --  Generate the parameter list for all cases. The abortable flag is
-      --  common among dispatching and regular requeue.
+         pragma Assert (Present (Acc_Ent));
 
-      Params := New_List (Abortable);
+         --  Recover the list of formal parameters
 
-      --  Ada 2005 (AI05-0030): We have a dispatching requeue of the form
-      --  Concval.Ename where the type of Concval is class-wide concurrent
-      --  interface.
+         if Nkind (Acc_Ent) = N_Entry_Body then
+            Acc_Ent := Entry_Body_Formal_Part (Acc_Ent);
+         end if;
 
-      if Ada_Version >= Ada_05
-        and then Present (Concval)
-        and then Is_Class_Wide_Type (Conc_Typ)
-        and then Is_Concurrent_Interface (Conc_Typ)
-      then
-         RTS_Call := Make_Identifier (Loc, Name_uDisp_Requeue);
+         Formals := Parameter_Specifications (Acc_Ent);
+
+         --  Create the actual parameters for the dispatching call. These are
+         --  simply copies of the entry body or accept statement formals in the
+         --  same order as they appear.
+
+         Actuals := No_List;
+
+         if Present (Formals) then
+            Actuals := New_List;
+            Formal  := First (Formals);
+            while Present (Formal) loop
+               Append_To (Actuals,
+                 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
+               Next (Formal);
+            end loop;
+         end if;
 
          --  Generate:
+         --    Obj.Call_Ent (Actuals);
+
+         return
+           Make_Procedure_Call_Statement (Loc,
+             Name =>
+               Make_Selected_Component (Loc,
+                 Prefix =>
+                   Make_Identifier (Loc, Chars (Obj)),
+                 Selector_Name =>
+                   Make_Identifier (Loc, Chars (Call_Ent))),
+
+             Parameter_Associations => Actuals);
+      end Build_Dispatching_Call_Equivalent;
+
+      -------------------------------
+      -- Build_Dispatching_Requeue --
+      -------------------------------
+
+      function Build_Dispatching_Requeue return Node_Id is
+         Params : constant List_Id := New_List;
+
+      begin
+         --  Process the "with abort" parameter
+
+         Prepend_To (Params,
+           New_Reference_To (Boolean_Literals (Abort_Present (N)), Loc));
+
+         --  Process the entry wrapper's position in the primary dispatch
+         --  table parameter. Generate:
+
          --    Ada.Tags.Get_Offset_Index
          --      (Ada.Tags.Tag (Concval),
          --       <interface dispatch table position of Ename>)
@@ -8435,156 +8532,389 @@  package body Exp_Ch9 is
            Make_Function_Call (Loc,
              Name =>
                New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
-             Parameter_Associations =>
-               New_List (
-                 Unchecked_Convert_To (RTE (RE_Tag), Concval),
-                 Make_Integer_Literal (Loc, DT_Position (Entity (Ename))))));
 
-         --  Specific actuals for protected to interface class-wide type
-         --  requeue.
+             Parameter_Associations => New_List (
+               Unchecked_Convert_To (RTE (RE_Tag), Concval),
+               Make_Integer_Literal (Loc, DT_Position (Entity (Ename))))));
+
+         --  Specific actuals for protected to XXX requeue
 
          if Is_Protected_Type (Old_Typ) then
             Prepend_To (Params,
               Make_Attribute_Reference (Loc,        --  _object'Address
                 Prefix =>
                   Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
-                Attribute_Name =>
-                  Name_Address));
+                Attribute_Name => Name_Address));
+
             Prepend_To (Params,                     --  True
               New_Reference_To (Standard_True, Loc));
 
-         --  Specific actuals for task to interface class-wide type requeue
+         --  Specific actuals for task to XXX requeue
 
          else
             pragma Assert (Is_Task_Type (Old_Typ));
 
             Prepend_To (Params,                     --  null
               New_Reference_To (RTE (RE_Null_Address), Loc));
+
             Prepend_To (Params,                     --  False
               New_Reference_To (Standard_False, Loc));
          end if;
 
-         --  Finally, add the common object parameter
+         --  Add the object parameter
 
          Prepend_To (Params, New_Copy_Tree (Concval));
 
-      --  Regular requeue processing
+         --  Generate:
+         --    _Disp_Requeue (<Params>);
 
-      else
-         New_Param := Concurrent_Ref (Concval);
+         return
+           Make_Procedure_Call_Statement (Loc,
+             Name =>
+               Make_Identifier (Loc, Name_uDisp_Requeue),
+             Parameter_Associations => Params);
+      end Build_Dispatching_Requeue;
+
+      --------------------------------------
+      -- Build_Dispatching_Requeue_To_Any --
+      --------------------------------------
+
+      function Build_Dispatching_Requeue_To_Any return Node_Id is
+         Call_Ent : constant Entity_Id := Entity (Ename);
+         Obj      : constant Node_Id   := Original_Node (Concval);
+         Skip     : constant Node_Id   := Build_Skip_Statement (N);
+         C        : Entity_Id;
+         Decls    : List_Id;
+         S        : Entity_Id;
+         Stmts    : List_Id;
+
+      begin
+         Decls := New_List;
+         Stmts := New_List;
+
+         --  Dispatch table slot processing, generate:
+         --    S : Integer;
+
+         S := Build_S (Loc, Decls);
 
-         --  The index expression is common among all four cases
+         --  Call kind processing, generate:
+         --    C : Ada.Tags.Prim_Op_Kind;
+
+         C := Build_C (Loc, Decls);
+
+         --  Generate:
+         --    S := Ada.Tags.Get_Offset_Index
+         --           (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
+
+         Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent));
+
+         --  Generate:
+         --    _Disp_Get_Prim_Op_Kind (Obj, S, C);
+
+         Append_To (Stmts,
+           Make_Procedure_Call_Statement (Loc,
+             Name =>
+               New_Reference_To (
+                 Find_Prim_Op (Etype (Etype (Obj)),
+                   Name_uDisp_Get_Prim_Op_Kind),
+                 Loc),
+             Parameter_Associations => New_List (
+               New_Copy_Tree (Obj),
+               New_Reference_To (S, Loc),
+               New_Reference_To (C, Loc))));
+
+         Append_To (Stmts,
+
+            --  if C = POK_Protected_Entry
+            --    or else C = POK_Task_Entry
+            --  then
+
+           Make_If_Statement (Loc,
+             Condition =>
+               Make_Op_Or (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))),
+
+               --  Dispatching requeue equivalent
+
+             Then_Statements => New_List (
+               Build_Dispatching_Requeue,
+               Skip),
+
+               --  elsif C = POK_Protected_Procedure then
+
+             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_Protected_Procedure), Loc)),
+
+                  --  Dispatching call equivalent
+
+                 Then_Statements => New_List (
+                   Build_Dispatching_Call_Equivalent))),
+
+            --  else
+            --     raise Program_Error;
+            --  end if;
+
+             Else_Statements => New_List (
+               Make_Raise_Program_Error (Loc,
+                 Reason => PE_Explicit_Raise))));
+
+         --  Wrap everything into a block
+
+         return
+           Make_Block_Statement (Loc,
+             Declarations => Decls,
+             Handled_Statement_Sequence =>
+               Make_Handled_Sequence_Of_Statements (Loc,
+                 Statements => Stmts));
+      end Build_Dispatching_Requeue_To_Any;
+
+      --------------------------
+      -- Build_Normal_Requeue --
+      --------------------------
+
+      function Build_Normal_Requeue return Node_Id is
+         Params  : constant List_Id := New_List;
+         Param   : Node_Id;
+         RT_Call : Node_Id;
+
+      begin
+         --  Process the "with abort" parameter
 
          Prepend_To (Params,
-           Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ));
+           New_Reference_To (Boolean_Literals (Abort_Present (N)), Loc));
 
-         if Is_Protected_Type (Old_Typ) then
-            Self_Param :=
-              Make_Attribute_Reference (Loc,
-                Prefix =>
-                  Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
-                Attribute_Name =>
-                  Name_Unchecked_Access);
+         --  Add the index expression to the parameters. It is common among all
+         --  four cases.
 
-            --  Protected to protected requeue
+         Prepend_To (Params,
+           Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ));
 
-            if Is_Protected_Type (Conc_Typ) then
-               RTS_Call :=
-                 New_Reference_To (RTE (RE_Requeue_Protected_Entry), Loc);
+         if Is_Protected_Type (Old_Typ) then
+            declare
+               Self_Param : Node_Id;
 
-               New_Param :=
+            begin
+               Self_Param :=
                  Make_Attribute_Reference (Loc,
                    Prefix =>
-                     New_Param,
+                     Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
                    Attribute_Name =>
                      Name_Unchecked_Access);
 
-            --  Protected to task requeue
+               --  Protected to protected requeue
 
-            else
-               pragma Assert (Is_Task_Type (Conc_Typ));
-               RTS_Call :=
-                 New_Reference_To (
-                   RTE (RE_Requeue_Protected_To_Task_Entry), Loc);
-            end if;
+               if Is_Protected_Type (Conc_Typ) then
+                  RT_Call :=
+                    New_Reference_To (
+                      RTE (RE_Requeue_Protected_Entry), Loc);
+
+                  Param :=
+                    Make_Attribute_Reference (Loc,
+                      Prefix =>
+                        Concurrent_Ref (Concval),
+                      Attribute_Name =>
+                        Name_Unchecked_Access);
 
-            Prepend (New_Param, Params);
-            Prepend (Self_Param, Params);
+               --  Protected to task requeue
 
-         else
-            pragma Assert (Is_Task_Type (Old_Typ));
+               else pragma Assert (Is_Task_Type (Conc_Typ));
+                  RT_Call :=
+                    New_Reference_To (
+                      RTE (RE_Requeue_Protected_To_Task_Entry), Loc);
+
+                  Param := Concurrent_Ref (Concval);
+               end if;
+
+               Prepend_To (Params, Param);
+               Prepend_To (Params, Self_Param);
+            end;
+
+         else pragma Assert (Is_Task_Type (Old_Typ));
 
             --  Task to protected requeue
 
             if Is_Protected_Type (Conc_Typ) then
-               RTS_Call :=
+               RT_Call :=
                  New_Reference_To (
                    RTE (RE_Requeue_Task_To_Protected_Entry), Loc);
 
-               New_Param :=
+               Param :=
                  Make_Attribute_Reference (Loc,
                    Prefix =>
-                     New_Param,
+                     Concurrent_Ref (Concval),
                    Attribute_Name =>
                      Name_Unchecked_Access);
 
             --  Task to task requeue
 
-            else
-               pragma Assert (Is_Task_Type (Conc_Typ));
-               RTS_Call :=
+            else pragma Assert (Is_Task_Type (Conc_Typ));
+               RT_Call :=
                  New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc);
+
+               Param := Concurrent_Ref (Concval);
             end if;
 
-            Prepend (New_Param, Params);
+            Prepend_To (Params, Param);
          end if;
-      end if;
-
-      --  Create the GNARLI or predefined primitive call
 
-      Rcall :=
-        Make_Procedure_Call_Statement (Loc,
-          Name => RTS_Call,
-          Parameter_Associations => Params);
+         return
+            Make_Procedure_Call_Statement (Loc,
+              Name => RT_Call,
+              Parameter_Associations => Params);
+      end Build_Normal_Requeue;
 
-      Rewrite (N, Rcall);
-      Analyze (N);
+      --------------------------
+      -- Build_Skip_Statement --
+      --------------------------
 
-      if Is_Protected_Type (Old_Typ) then
+      function Build_Skip_Statement (Search : Node_Id) return Node_Id is
+         Skip_Stmt : Node_Id;
 
-         --  Build the return statement to skip the rest of the entry body
+      begin
+         --  Build a return statement to skip the rest of the entire body
 
-         Skip_Stat := Make_Simple_Return_Statement (Loc);
+         if Is_Protected_Type (Old_Typ) then
+            Skip_Stmt := Make_Simple_Return_Statement (Loc);
 
-      else
          --  If the requeue is within a task, find the end label of the
-         --  enclosing accept statement.
+         --  enclosing accept statement and create a goto statement to it.
 
-         Acc_Stat := Parent (N);
-         while Nkind (Acc_Stat) /= N_Accept_Statement loop
-            Acc_Stat := Parent (Acc_Stat);
-         end loop;
+         else
+            declare
+               Acc   : Node_Id;
+               Label : Node_Id;
 
-         --  The last statement is the second label, used for completing the
-         --  rendezvous the usual way. The label we are looking for is right
-         --  before it.
+            begin
+               --  Climb the parent chain looking for the enclosing accept
+               --  statement.
 
-         Lab_Node :=
-           Prev (Last (Statements (Handled_Statement_Sequence (Acc_Stat))));
+               Acc := Parent (Search);
+               while Present (Acc)
+                 and then Nkind (Acc) /= N_Accept_Statement
+               loop
+                  Acc := Parent (Acc);
+               end loop;
 
-         pragma Assert (Nkind (Lab_Node) = N_Label);
+               --  The last statement is the second label used for completing
+               --  the rendezvous the usual way. The label we are looking for
+               --  is right before it.
 
-         --  Build the goto statement to skip the rest of the accept
-         --  statement.
+               Label :=
+                 Prev (Last (Statements (Handled_Statement_Sequence (Acc))));
 
-         Skip_Stat :=
-           Make_Goto_Statement (Loc,
-             Name => New_Occurrence_Of (Entity (Identifier (Lab_Node)), Loc));
-      end if;
+               pragma Assert (Nkind (Label) = N_Label);
+
+               --  Generate a goto statement to skip the rest of the accept
+
+               Skip_Stmt :=
+                 Make_Goto_Statement (Loc,
+                   Name =>
+                     New_Occurrence_Of (Entity (Identifier (Label)), Loc));
+            end;
+         end if;
+
+         Set_Analyzed (Skip_Stmt);
+
+         return Skip_Stmt;
+      end Build_Skip_Statement;
+
+   --  Start of processing for Expand_N_Requeue_Statement
 
-      Set_Analyzed (Skip_Stat);
+   begin
+      --  Extract the components of the entry call
+
+      Extract_Entry (N, Concval, Ename, Index);
+      Conc_Typ := Etype (Concval);
+
+      --  Examine the scope stack in order to find nearest enclosing protected
+      --  or task type. This will constitute our invocation source.
+
+      Old_Typ := Current_Scope;
+      while Present (Old_Typ)
+        and then not Is_Protected_Type (Old_Typ)
+        and then not Is_Task_Type (Old_Typ)
+      loop
+         Old_Typ := Scope (Old_Typ);
+      end loop;
 
-      Insert_After (N, Skip_Stat);
+      --  Ada 2012 (AI05-0030): We have a dispatching requeue of the form
+      --  Concval.Ename where the type of Concval is class-wide concurrent
+      --  interface.
+
+      if Ada_Version >= Ada_2012
+        and then Present (Concval)
+        and then Is_Class_Wide_Type (Conc_Typ)
+        and then Is_Concurrent_Interface (Conc_Typ)
+      then
+         declare
+            Has_Impl  : Boolean := False;
+            Impl_Kind : Name_Id := No_Name;
+
+         begin
+            --  Check whether the Ename is flagged by pragma Implemented
+
+            if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then
+               Has_Impl  := True;
+               Impl_Kind := Implementation_Kind (Entity (Ename));
+            end if;
+
+            --  The procedure_or_entry_NAME is guaranteed to be overridden by
+            --  an entry. Create a call to predefined primitive _Disp_Requeue.
+
+            if Has_Impl
+              and then Impl_Kind = Name_By_Entry
+            then
+               Rewrite (N, Build_Dispatching_Requeue);
+               Analyze (N);
+               Insert_After (N, Build_Skip_Statement (N));
+
+            --  The procedure_or_entry_NAME is guaranteed to be overridden by
+            --  a protected procedure. In this case the requeue is transformed
+            --  into a dispatching call.
+
+            elsif Has_Impl
+              and then Impl_Kind = Name_By_Protected_Procedure
+            then
+               Rewrite (N, Build_Dispatching_Call_Equivalent);
+               Analyze (N);
+
+            --  The procedure_or_entry_NAME's implementation kind is either
+            --  By_Any or pragma Implemented was not applied at all. In this
+            --  case a runtime test determines whether Ename denotes an entry
+            --  or a protected procedure and performs the appropriate call.
+
+            else
+               Rewrite (N, Build_Dispatching_Requeue_To_Any);
+               Analyze (N);
+            end if;
+         end;
+
+      --  Processing for regular (non-dispatching) requeues
+
+      else
+         Rewrite (N, Build_Normal_Requeue);
+         Analyze (N);
+         Insert_After (N, Build_Skip_Statement (N));
+      end if;
    end Expand_N_Requeue_Statement;
 
    -------------------------------
Index: sem_ch9.adb
===================================================================
--- sem_ch9.adb	(revision 165080)
+++ sem_ch9.adb	(working copy)
@@ -1423,18 +1423,17 @@  package body Sem_Ch9 is
          Entry_Id := Entity (Entry_Name);
       end if;
 
-      --  Ada 2005 (AI05-0030): Potential dispatching requeue statement. The
+      --  Ada 2012 (AI05-0030): Potential dispatching requeue statement. The
       --  target type must be a concurrent interface class-wide type and the
-      --  entry name must be a procedure, flagged by pragma Implemented_By_
-      --  Entry.
+      --  target must be a procedure, flagged by pragma Implemented.
 
       Is_Disp_Req :=
-        Ada_Version >= Ada_05
+        Ada_Version >= Ada_2012
           and then Present (Target_Obj)
           and then Is_Class_Wide_Type (Etype (Target_Obj))
           and then Is_Concurrent_Interface (Etype (Target_Obj))
           and then Ekind (Entry_Id) = E_Procedure
-          and then Implemented_By_Entry (Entry_Id);
+          and then Has_Rep_Pragma (Entry_Id, Name_Implemented);
 
       --  Resolve entry, and check that it is subtype conformant with the
       --  enclosing construct if this construct has formals (RM 9.5.4(5)).
@@ -1462,11 +1461,13 @@  package body Sem_Ch9 is
                return;
             end if;
 
-            --  Ada 2005 (AI05-0030): Perform type conformance after skipping
+            --  Ada 2012 (AI05-0030): Perform type conformance after skipping
             --  the first parameter of Entry_Id since it is the interface
             --  controlling formal.
 
-            if Is_Disp_Req then
+            if Ada_Version >= Ada_2012
+              and then Is_Disp_Req
+            then
                declare
                   Enclosing_Formal : Entity_Id;
                   Target_Formal    : Entity_Id;
Index: einfo.adb
===================================================================
--- einfo.adb	(revision 165082)
+++ einfo.adb	(working copy)
@@ -493,7 +493,6 @@  package body Einfo is
    --    Has_Pragma_Inline_Always        Flag230
 
    --    Renamed_In_Spec                 Flag231
-   --    Implemented_By_Entry            Flag232
    --    Has_Pragma_Unmodified           Flag233
    --    Is_Dispatch_Table_Entity        Flag234
    --    Is_Trivial_Subprogram           Flag235
@@ -512,6 +511,7 @@  package body Einfo is
    --    OK_To_Rename                    Flag247
 
    --    (unused)                        Flag200
+   --    (unused)                        Flag232
 
    -----------------------
    -- Local subprograms --
@@ -1536,12 +1536,6 @@  package body Einfo is
       return Node4 (Id);
    end Homonym;
 
-   function Implemented_By_Entry (Id : E) return B is
-   begin
-      pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
-      return Flag232 (Id);
-   end Implemented_By_Entry;
-
    function Interfaces (Id : E) return L is
    begin
       pragma Assert (Is_Record_Type (Id));
@@ -3958,12 +3952,6 @@  package body Einfo is
       Set_Node4 (Id, V);
    end Set_Homonym;
 
-   procedure Set_Implemented_By_Entry (Id : E; V : B := True) is
-   begin
-      pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
-      Set_Flag232 (Id, V);
-   end Set_Implemented_By_Entry;
-
    procedure Set_Interfaces (Id : E; V : L) is
    begin
       pragma Assert (Is_Record_Type (Id));
@@ -6958,7 +6946,6 @@  package body Einfo is
       W ("Has_Up_Level_Access",             Flag215 (Id));
       W ("Has_Volatile_Components",         Flag87  (Id));
       W ("Has_Xref_Entry",                  Flag182 (Id));
-      W ("Implemented_By_Entry",            Flag232 (Id));
       W ("In_Package_Body",                 Flag48  (Id));
       W ("In_Private_Part",                 Flag45  (Id));
       W ("In_Use",                          Flag8   (Id));
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 165104)
+++ einfo.ads	(working copy)
@@ -1806,10 +1806,6 @@  package Einfo is
 --       that we still have a concrete type. For entities other than types,
 --       returns the entity unchanged.
 
---    Implemented_By_Entry (Flag232)
---       Applies to functions and procedures. Set if pragma Implemented_By_
---       Entry is applied on the subprogram entity.
-
 --    Interfaces (Elist25)
 --       Present in record types and subtypes. List of abstract interfaces
 --       implemented by a tagged type that are not already implemented by the
@@ -5052,7 +5048,6 @@  package Einfo is
    --    Has_Postconditions                  (Flag240)
    --    Has_Recursive_Call                  (Flag143)
    --    Has_Subprogram_Descriptor           (Flag93)
-   --    Implemented_By_Entry                (Flag232)  (non-generic case only)
    --    Is_Abstract_Subprogram              (Flag19)   (non-generic case only)
    --    Is_Called                           (Flag102)  (non-generic case only)
    --    Is_Constructor                      (Flag76)
@@ -5311,7 +5306,6 @@  package Einfo is
    --    Has_Nested_Block_With_Handler       (Flag101)
    --    Has_Postconditions                  (Flag240)
    --    Has_Subprogram_Descriptor           (Flag93)
-   --    Implemented_By_Entry                (Flag232)  (non-generic case only)
    --    Is_Abstract_Subprogram              (Flag19)   (non-generic case only)
    --    Is_Asynchronous                     (Flag81)
    --    Is_Called                           (Flag102)  (non-generic case only)
@@ -5928,7 +5922,6 @@  package Einfo is
    function Has_Xref_Entry                      (Id : E) return B;
    function Hiding_Loop_Variable                (Id : E) return E;
    function Homonym                             (Id : E) return E;
-   function Implemented_By_Entry                (Id : E) return B;
    function In_Package_Body                     (Id : E) return B;
    function In_Private_Part                     (Id : E) return B;
    function In_Use                              (Id : E) return B;
@@ -6490,7 +6483,6 @@  package Einfo is
    procedure Set_Has_Xref_Entry                  (Id : E; V : B := True);
    procedure Set_Hiding_Loop_Variable            (Id : E; V : E);
    procedure Set_Homonym                         (Id : E; V : E);
-   procedure Set_Implemented_By_Entry            (Id : E; V : B := True);
    procedure Set_Interfaces                      (Id : E; V : L);
    procedure Set_In_Package_Body                 (Id : E; V : B := True);
    procedure Set_In_Private_Part                 (Id : E; V : B := True);
@@ -7150,7 +7142,6 @@  package Einfo is
    pragma Inline (Has_Xref_Entry);
    pragma Inline (Hiding_Loop_Variable);
    pragma Inline (Homonym);
-   pragma Inline (Implemented_By_Entry);
    pragma Inline (Interfaces);
    pragma Inline (In_Package_Body);
    pragma Inline (In_Private_Part);
@@ -7583,7 +7574,6 @@  package Einfo is
    pragma Inline (Set_Has_Xref_Entry);
    pragma Inline (Set_Hiding_Loop_Variable);
    pragma Inline (Set_Homonym);
-   pragma Inline (Set_Implemented_By_Entry);
    pragma Inline (Set_Interfaces);
    pragma Inline (Set_In_Package_Body);
    pragma Inline (Set_In_Private_Part);
Index: sem_prag.adb
===================================================================
--- sem_prag.adb	(revision 165110)
+++ sem_prag.adb	(working copy)
@@ -310,7 +310,12 @@  package body Sem_Prag is
       procedure Ada_2005_Pragma;
       --  Called for pragmas defined in Ada 2005, that are not in Ada 95. In
       --  Ada 95 mode, these are implementation defined pragmas, so should be
-      --  caught by the No_Implementation_Pragmas restriction
+      --  caught by the No_Implementation_Pragmas restriction.
+
+      procedure Ada_2012_Pragma;
+      --  Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
+      --  In Ada 95 or 05 mode, these are implementation defined pragmas, so
+      --  should be caught by the No_Implementation_Pragmas restriction.
 
       procedure Check_Ada_83_Warning;
       --  Issues a warning message for the current pragma if operating in Ada
@@ -733,6 +738,17 @@  package body Sem_Prag is
          end if;
       end Ada_2005_Pragma;
 
+      ---------------------
+      -- Ada_2012_Pragma --
+      ---------------------
+
+      procedure Ada_2012_Pragma is
+      begin
+         if Ada_Version <= Ada_05 then
+            Check_Restriction (No_Implementation_Pragmas, N);
+         end if;
+      end Ada_2012_Pragma;
+
       --------------------------
       -- Check_Ada_83_Warning --
       --------------------------
@@ -7979,45 +7995,101 @@  package body Sem_Prag is
             end;
          end Ident;
 
-         --------------------------
-         -- Implemented_By_Entry --
-         --------------------------
+         -----------------
+         -- Implemented --
+         -----------------
 
-         --  pragma Implemented_By_Entry (DIRECT_NAME);
+         --  pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
+         --  implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
 
-         when Pragma_Implemented_By_Entry => Implemented_By_Entry : declare
-            Ent : Entity_Id;
+         when Pragma_Implemented => Implemented : declare
+            Proc_Id : Entity_Id;
+            Typ     : Entity_Id;
 
          begin
-            Ada_2005_Pragma;
-            Check_Arg_Count (1);
+            Ada_2012_Pragma;
+            Check_Arg_Count (2);
             Check_No_Identifiers;
             Check_Arg_Is_Identifier (Arg1);
             Check_Arg_Is_Local_Name (Arg1);
-            Ent := Entity (Expression (Arg1));
+            Check_Arg_Is_One_Of
+              (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
+
+            --  Extract the name of the local procedure
 
-            --  Pragma Implemented_By_Entry must be applied only to protected
-            --  synchronized or task interface primitives.
+            Proc_Id := Entity (Expression (Arg1));
 
-            if (Ekind (Ent) /= E_Function
-                  and then Ekind (Ent) /= E_Procedure)
-               or else not Present (First_Formal (Ent))
-               or else not Is_Concurrent_Interface (Etype (First_Formal (Ent)))
+            --  Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
+            --  primitive procedure of a synchronized tagged type.
+
+            if Ekind (Proc_Id) = E_Procedure
+              and then Is_Primitive (Proc_Id)
+              and then Present (First_Formal (Proc_Id))
             then
-               Error_Pragma_Arg
-                 ("pragma % must be applied to a concurrent interface " &
-                  "primitive", Arg1);
+               Typ := Etype (First_Formal (Proc_Id));
 
-            else
-               if Einfo.Implemented_By_Entry (Ent)
-                 and then Warn_On_Redundant_Constructs
+               if Is_Tagged_Type (Typ)
+                 and then
+
+                  --  Check for a protected, a synchronized or a task interface
+
+                   ((Is_Interface (Typ)
+                       and then Is_Synchronized_Interface (Typ))
+
+                  --  Check for a protected type or a task type that implements
+                  --  an interface.
+
+                   or else
+                    (Is_Concurrent_Record_Type (Typ)
+                       and then Present (Interfaces (Typ)))
+
+                  --  Check for a private record extension with keyword
+                  --  "synchronized".
+
+                   or else
+                    (Ekind_In (Typ, E_Record_Type_With_Private,
+                                    E_Record_Subtype_With_Private)
+                       and then Synchronized_Present (Parent (Typ))))
                then
-                  Error_Pragma ("?duplicate pragma%!");
+                  null;
                else
-                  Set_Implemented_By_Entry (Ent);
+                  Error_Pragma_Arg
+                    ("controlling formal must be of synchronized " &
+                     "tagged type", Arg1);
+                  return;
                end if;
+
+            --  Procedures declared inside a protected type must be accepted
+
+            elsif Ekind (Proc_Id) = E_Procedure
+              and then Is_Protected_Type (Scope (Proc_Id))
+            then
+               null;
+
+            --  The first argument is not a primitive procedure
+
+            else
+               Error_Pragma_Arg
+                 ("pragma % must be applied to a primitive procedure", Arg1);
+               return;
             end if;
-         end Implemented_By_Entry;
+
+            --  Ada 2012 (AI05-0030): Implementation_kind "By_Protected_
+            --  Procedure" cannot be applied to the primitive procedure of a
+            --  task interface.
+
+            if Chars (Arg2) = Name_By_Protected_Procedure
+              and then Is_Interface (Typ)
+              and then Is_Task_Interface (Typ)
+            then
+               Error_Pragma_Arg
+                 ("implementation kind By_Protected_Procedure cannot be " &
+                  "applied to a task interface primitive", Arg2);
+               return;
+            end if;
+
+            Record_Rep_Item (Proc_Id, N);
+         end Implemented;
 
          -----------------------
          -- Implicit_Packing --
@@ -12946,7 +13018,7 @@  package body Sem_Prag is
       Pragma_Finalize_Storage_Only         =>  0,
       Pragma_Float_Representation          =>  0,
       Pragma_Ident                         => -1,
-      Pragma_Implemented_By_Entry          => -1,
+      Pragma_Implemented                   => -1,
       Pragma_Implicit_Packing              =>  0,
       Pragma_Import                        => +2,
       Pragma_Import_Exception              =>  0,
Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 165092)
+++ sem_util.adb	(working copy)
@@ -5237,6 +5237,20 @@  package body Sem_Util is
       end if;
    end Has_Tagged_Component;
 
+   -------------------------
+   -- Implementation_Kind --
+   -------------------------
+
+   function Implementation_Kind (Subp : Entity_Id) return Name_Id is
+      Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
+
+   begin
+      pragma Assert (Present (Impl_Prag));
+
+      return
+        Chars (Expression (Last (Pragma_Argument_Associations (Impl_Prag))));
+   end Implementation_Kind;
+
    --------------------------
    -- Implements_Interface --
    --------------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads	(revision 165103)
+++ sem_util.ads	(working copy)
@@ -586,11 +586,16 @@  package Sem_Util is
    --  component is present. This function is used to check if "=" has to be
    --  expanded into a bunch component comparisons.
 
+   function Implementation_Kind (Subp : Entity_Id) return Name_Id;
+   --  Subp is a subprogram marked with pragma Implemented. Return the specific
+   --  implementation requirement which the pragma imposes. The return value is
+   --  either Name_By_Any, Name_By_Entry or Name_By_Protected_Procedure.
+
    function Implements_Interface
      (Typ_Ent         : Entity_Id;
       Iface_Ent       : Entity_Id;
       Exclude_Parents : Boolean := False) return Boolean;
-   --  Returns true if the Typ implements interface Iface
+   --  Returns true if the Typ_Ent implements interface Iface_Ent
 
    function In_Instance return Boolean;
    --  Returns True if the current scope is within a generic instance
Index: par-prag.adb
===================================================================
--- par-prag.adb	(revision 165082)
+++ par-prag.adb	(working copy)
@@ -1123,7 +1123,7 @@  begin
            Pragma_Finalize_Storage_Only         |
            Pragma_Float_Representation          |
            Pragma_Ident                         |
-           Pragma_Implemented_By_Entry          |
+           Pragma_Implemented                   |
            Pragma_Implicit_Packing              |
            Pragma_Import                        |
            Pragma_Import_Exception              |
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl	(revision 165080)
+++ snames.ads-tmpl	(working copy)
@@ -445,7 +445,7 @@  package Snames is
    Name_External                       : constant Name_Id := N + $; -- GNAT
    Name_Finalize_Storage_Only          : constant Name_Id := N + $; -- GNAT
    Name_Ident                          : constant Name_Id := N + $; -- VMS
-   Name_Implemented_By_Entry           : constant Name_Id := N + $; -- Ada 05
+   Name_Implemented                    : constant Name_Id := N + $; -- Ada 12
    Name_Import                         : constant Name_Id := N + $;
    Name_Import_Exception               : constant Name_Id := N + $; -- VMS
    Name_Import_Function                : constant Name_Id := N + $; -- GNAT
@@ -594,6 +594,9 @@  package Snames is
    Name_Attribute_Name                 : constant Name_Id := N + $;
    Name_Body_File_Name                 : constant Name_Id := N + $;
    Name_Boolean_Entry_Barriers         : constant Name_Id := N + $;
+   Name_By_Any                         : constant Name_Id := N + $;
+   Name_By_Entry                       : constant Name_Id := N + $;
+   Name_By_Protected_Procedure         : constant Name_Id := N + $;
    Name_Casing                         : constant Name_Id := N + $;
    Name_Code                           : constant Name_Id := N + $;
    Name_Component                      : constant Name_Id := N + $;
@@ -1520,7 +1523,7 @@  package Snames is
       Pragma_External,
       Pragma_Finalize_Storage_Only,
       Pragma_Ident,
-      Pragma_Implemented_By_Entry,
+      Pragma_Implemented,
       Pragma_Import,
       Pragma_Import_Exception,
       Pragma_Import_Function,