2010-10-08 Thomas Quinot <quinot@adacore.com>

	* sem_ch4.adb: Minor reformatting.

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.

2010-10-08  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Expand_Freeeze_Record_Type): Code cleanup: remove local
	variable Has_Static_DT by invocation of function Building_Static_DT.

2010-10-08  Vincent Celier  <celier@adacore.com>

	* g-dirope.adb (Remove_Dir): Do not change the current directory when
	doing a recursive remove of a subdirectory.

2010-10-08  Javier Miranda  <miranda@adacore.com>

	* exp_ch6.ad (Freeze_Subprogram): Factorize code.
	* exp_disp.adb (Make_Secondary_DT): Factorize code.
	(Make_DT): Factorize code.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165154 138bc75d-0d04-0410-961f-82ee72b054a4

16 files changed, 874 insertions, 271 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index bfec7bc74df..364f268fc4f 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,63 @@
+2010-10-08  Thomas Quinot  <quinot@adacore.com>
+
+	* sem_ch4.adb: Minor reformatting.
+
+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.
+
+2010-10-08  Javier Miranda  <miranda@adacore.com>
+
+	* exp_ch3.adb (Expand_Freeeze_Record_Type): Code cleanup: remove local
+	variable Has_Static_DT by invocation of function Building_Static_DT.
+
+2010-10-08  Vincent Celier  <celier@adacore.com>
+
+	* g-dirope.adb (Remove_Dir): Do not change the current directory when
+	doing a recursive remove of a subdirectory.
+
+2010-10-08  Javier Miranda  <miranda@adacore.com>
+
+	* exp_ch6.ad (Freeze_Subprogram): Factorize code.
+	* exp_disp.adb (Make_Secondary_DT): Factorize code.
+	(Make_DT): Factorize code.
+
 2010-10-08  Robert Dewar  <dewar@adacore.com>
 
 	* sem_ch4.adb: Minor reformatting.
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 6fe87a7d4db..7ec3f8dc1b9 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -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));
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 6c1aa2f78b4..074eefc160a 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -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);
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 7a00d39c3c3..0995f5a1b04 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -5863,7 +5863,6 @@ package body Exp_Ch3 is
       Type_Decl     : constant Node_Id := Parent (Def_Id);
       Comp          : Entity_Id;
       Comp_Typ      : Entity_Id;
-      Has_Static_DT : Boolean := False;
       Predef_List   : List_Id;
 
       Flist : Entity_Id := Empty;
@@ -5982,9 +5981,6 @@ package body Exp_Ch3 is
       --  just use it.
 
       if Is_Tagged_Type (Def_Id) then
-         Has_Static_DT :=
-           Static_Dispatch_Tables
-             and then Is_Library_Level_Tagged_Type (Def_Id);
 
          --  Add the _Tag component
 
@@ -6004,7 +6000,7 @@ package body Exp_Ch3 is
             Set_CPP_Constructors (Def_Id);
 
          else
-            if not Has_Static_DT then
+            if not Building_Static_DT (Def_Id) then
 
                --  Usually inherited primitives are not delayed but the first
                --  Ada extension of a CPP_Class is an exception since the
@@ -6116,7 +6112,7 @@ package body Exp_Ch3 is
                --  Dispatch tables of library level tagged types are built
                --  later (see Analyze_Declarations).
 
-               if not Has_Static_DT then
+               if not Building_Static_DT (Def_Id) then
                   Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
                end if;
             end if;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index eb30d804ee0..6cfc955ffa5 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -4998,10 +4998,8 @@ package body Exp_Ch6 is
             --  Generate code to register the primitive in non statically
             --  allocated dispatch tables
 
-            elsif not Static_Dispatch_Tables
-              or else not
-                Is_Library_Level_Tagged_Type (Scope (DTC_Entity (Subp)))
-            then
+            elsif not Building_Static_DT (Scope (DTC_Entity (Subp))) then
+
                --  When a primitive is frozen, enter its name in its dispatch
                --  table slot.
 
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index a91ec6a4c22..90853ea46e4 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -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;
 
-         --  The index expression is common among all four cases
+         --  Dispatch table slot processing, generate:
+         --    S : Integer;
+
+         S := Build_S (Loc, Decls);
+
+         --  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.
+
+               Acc := Parent (Search);
+               while Present (Acc)
+                 and then Nkind (Acc) /= N_Accept_Statement
+               loop
+                  Acc := Parent (Acc);
+               end loop;
 
-         Lab_Node :=
-           Prev (Last (Statements (Handled_Statement_Sequence (Acc_Stat))));
+               --  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.
 
-         pragma Assert (Nkind (Lab_Node) = N_Label);
+               Label :=
+                 Prev (Last (Statements (Handled_Statement_Sequence (Acc))));
 
-         --  Build the goto statement to skip the rest of the accept
-         --  statement.
+               pragma Assert (Nkind (Label) = N_Label);
 
-         Skip_Stat :=
-           Make_Goto_Statement (Loc,
-             Name => New_Occurrence_Of (Entity (Identifier (Lab_Node)), Loc));
-      end if;
+               --  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;
 
    -------------------------------
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index c38bbe8bf5d..af3a0b38536 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -4060,8 +4060,7 @@ package body Exp_Disp is
             Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
 
          elsif Is_Abstract_Type (Typ)
-           or else not Static_Dispatch_Tables
-           or else not Is_Library_Level_Tagged_Type (Typ)
+           or else not Building_Static_DT (Typ)
          then
             for J in 1 .. Nb_Prim loop
                Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
@@ -5614,9 +5613,7 @@ package body Exp_Disp is
          if Nb_Prim = 0 then
             Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
 
-         elsif not Static_Dispatch_Tables
-           or else not Is_Library_Level_Tagged_Type (Typ)
-         then
+         elsif not Building_Static_DT (Typ) then
             for J in 1 .. Nb_Prim loop
                Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
             end loop;
@@ -5768,9 +5765,7 @@ package body Exp_Disp is
       --  because the whole dispatch table (including inherited primitives) has
       --  been already built.
 
-      if Static_Dispatch_Tables
-        and then Is_Library_Level_Tagged_Type (Typ)
-      then
+      if Building_Static_DT (Typ) then
          null;
 
       --  If the ancestor is a CPP_Class type we inherit the dispatch tables
diff --git a/gcc/ada/g-dirope.adb b/gcc/ada/g-dirope.adb
index 294aa7031ee..50e8b478556 100644
--- a/gcc/ada/g-dirope.adb
+++ b/gcc/ada/g-dirope.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                     Copyright (C) 1998-2009, AdaCore                     --
+--                     Copyright (C) 1998-2010, AdaCore                     --
 --                                                                          --
 -- 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- --
@@ -719,11 +719,10 @@ package body GNAT.Directory_Operations is
       Recursive : Boolean := False)
    is
       C_Dir_Name  : constant String := Dir_Name & ASCII.NUL;
-      Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
       Last        : Integer;
       Str         : String (1 .. Filename_Max);
       Success     : Boolean;
-      Working_Dir : Dir_Type;
+      Current_Dir : Dir_Type;
 
    begin
       --  Remove the directory only if it is empty
@@ -736,51 +735,40 @@ package body GNAT.Directory_Operations is
       --  Remove directory and all files and directories that it may contain
 
       else
-         --  Substantial comments needed. See RH for revision 1.50 ???
+         Open (Current_Dir, Dir_Name);
 
-         begin
-            Change_Dir (Dir_Name);
-            Open (Working_Dir, ".");
-
-            loop
-               Read (Working_Dir, Str, Last);
-               exit when Last = 0;
-
-               if GNAT.OS_Lib.Is_Directory (Str (1 .. Last)) then
-                  if Str (1 .. Last) /= "."
-                       and then
-                     Str (1 .. Last) /= ".."
-                  then
-                     Remove_Dir (Str (1 .. Last), True);
-                  end if;
-
-               else
-                  GNAT.OS_Lib.Delete_File (Str (1 .. Last), Success);
+         loop
+            Read (Current_Dir, Str, Last);
+            exit when Last = 0;
 
-                  if not Success then
-                     Change_Dir (Current_Dir);
-                     raise Directory_Error;
-                  end if;
+            if GNAT.OS_Lib.Is_Directory
+                 (Dir_Name & Dir_Separator &  Str (1 .. Last))
+            then
+               if Str (1 .. Last) /= "."
+                 and then
+                   Str (1 .. Last) /= ".."
+               then
+                  --  Recursive call to remove a subdirectory and all its
+                  --  files.
+
+                  Remove_Dir
+                    (Dir_Name & Dir_Separator &  Str (1 .. Last),
+                     True);
                end if;
-            end loop;
-
-            Change_Dir (Current_Dir);
-            Close (Working_Dir);
-            Remove_Dir (Dir_Name);
-
-         exception
-            when others =>
 
-               --  An exception occurred. We must make sure the current working
-               --  directory is unchanged.
-
-               Change_Dir (Current_Dir);
+            else
+               GNAT.OS_Lib.Delete_File
+                 (Dir_Name & Dir_Separator &  Str (1 .. Last),
+                  Success);
 
-               --  What if the Change_Dir raises an exception itself, shouldn't
-               --  that be protected? ???
+               if not Success then
+                  raise Directory_Error;
+               end if;
+            end if;
+         end loop;
 
-               raise;
-         end;
+         Close (Current_Dir);
+         Remove_Dir (Dir_Name);
       end if;
    end Remove_Dir;
 
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index e6c34e4dc10..190c9cc1529 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -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              |
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 6b008ae8697..18aced728e3 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -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);
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 5891e9b14d5..154b5d3376d 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -507,7 +507,7 @@ package body Sem_Ch4 is
             --  be a null object, and we can insert an unconditional raise
             --  before the allocator.
 
-            --  Ada2012 (AI-104): a not null indication here is altogether
+            --  Ada 2012 (AI-104): A not null indication here is altogether
             --  illegal.
 
             if Can_Never_Be_Null (Type_Id) then
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index 792a9dad4c5..136dfb353b4 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -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;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 721b34db68e..1ad6c67d7f4 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -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,
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 917104c1f6c..d9991ce3e58 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -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 --
    --------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index aa044514c48..faa363cbcc6 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -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
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index efba4c6fc34..0425cccc77e 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -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,