2011-08-31 Robert Dewar <dewar@adacore.com>

	* exp_ch5.adb, exp_alfa.ads, prj.ads, sem_attr.adb,
	lib-xref-alfa.adb: Minor reformatting.

2011-08-31  Matthew Heaney  <heaney@adacore.com>

	* a-crbltr.ads (Tree_Type): Default-initialize the Nodes component.

2011-08-31  Javier Miranda  <miranda@adacore.com>

	* sem_ch4.adb (Try_Object_Operation): Addition of one formal to search
	only for class-wide subprograms conflicting with entities of concurrent
	tagged types.

2011-08-31  Matthew Heaney  <heaney@adacore.com>

	* a-rbtgbo.adb (Generic_Allocate): Initialize pointer components of
	node to null value.

2011-08-31  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch12.adb (Insert_Freeze_Node_For_Instance): Provide a more
	general description of the routine.

2011-08-31  Ed Schonberg  <schonberg@adacore.com>

	* a-cbdlli.adb, a-cbdlli.ads: Add iterator machinery to bounded
	doubly-linked lists.



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

12 files changed, 353 insertions, 44 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index bcb79fce61e..a48149e19b6 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,33 @@
+2011-08-31  Robert Dewar  <dewar@adacore.com>
+
+	* exp_ch5.adb, exp_alfa.ads, prj.ads, sem_attr.adb,
+	lib-xref-alfa.adb: Minor reformatting.
+
+2011-08-31  Matthew Heaney  <heaney@adacore.com>
+
+	* a-crbltr.ads (Tree_Type): Default-initialize the Nodes component.
+
+2011-08-31  Javier Miranda  <miranda@adacore.com>
+
+	* sem_ch4.adb (Try_Object_Operation): Addition of one formal to search
+	only for class-wide subprograms conflicting with entities of concurrent
+	tagged types.
+
+2011-08-31  Matthew Heaney  <heaney@adacore.com>
+
+	* a-rbtgbo.adb (Generic_Allocate): Initialize pointer components of
+	node to null value.
+
+2011-08-31  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* sem_ch12.adb (Insert_Freeze_Node_For_Instance): Provide a more
+	general description of the routine.
+
+2011-08-31  Ed Schonberg  <schonberg@adacore.com>
+
+	* a-cbdlli.adb, a-cbdlli.ads: Add iterator machinery to bounded
+	doubly-linked lists.
+
 2011-08-31  Gary Dismukes  <dismukes@adacore.com>
 
 	* exp_ch5.adb (Expand_N_Assignment_Statement): When a discriminant
diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb
index 61615a0c89b..cf2422748d2 100644
--- a/gcc/ada/a-cbdlli.adb
+++ b/gcc/ada/a-cbdlli.adb
@@ -30,6 +30,22 @@
 with System;  use type System.Address;
 
 package body Ada.Containers.Bounded_Doubly_Linked_Lists is
+   type Iterator is new
+     List_Iterator_Interfaces.Reversible_Iterator with record
+        Container : List_Access;
+        Node      : Count_Type;
+   end record;
+
+   overriding function First (Object : Iterator) return Cursor;
+   overriding function Last  (Object : Iterator) return Cursor;
+
+   overriding function Next
+     (Object   : Iterator;
+      Position : Cursor) return Cursor;
+
+   overriding function Previous
+     (Object   : Iterator;
+      Position : Cursor) return Cursor;
 
    -----------------------
    -- Local Subprograms --
@@ -526,6 +542,15 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
       return Cursor'(Container'Unrestricted_Access, Container.First);
    end First;
 
+   function First (Object : Iterator) return Cursor is
+   begin
+      if Object.Container = null then
+         return No_Element;
+      else
+         return (Object.Container, Object.Container.First);
+      end if;
+   end First;
+
    -------------------
    -- First_Element --
    -------------------
@@ -1030,6 +1055,25 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
       B := B - 1;
    end Iterate;
 
+   function Iterate (Container : List)
+     return List_Iterator_Interfaces.Reversible_Iterator'class
+   is
+   begin
+      if Container.Length = 0 then
+         return Iterator'(null, Count_Type'First);
+      else
+         return Iterator'(Container'Unrestricted_Access, Container.First);
+      end if;
+   end Iterate;
+
+   function Iterate (Container : List; Start : Cursor)
+     return List_Iterator_Interfaces.Reversible_Iterator'class
+   is
+      It : constant Iterator := (Container'Unrestricted_Access, Start.Node);
+   begin
+      return It;
+   end Iterate;
+
    ----------
    -- Last --
    ----------
@@ -1043,6 +1087,15 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
       return Cursor'(Container'Unrestricted_Access, Container.Last);
    end Last;
 
+   function Last (Object : Iterator) return Cursor is
+   begin
+      if Object.Container = null then
+         return No_Element;
+      else
+         return (Object.Container, Object.Container.Last);
+      end if;
+   end Last;
+
    ------------------
    -- Last_Element --
    ------------------
@@ -1133,6 +1186,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
       end;
    end Next;
 
+   function Next
+     (Object   : Iterator;
+      Position : Cursor) return Cursor
+   is
+      Nodes : Node_Array renames Position.Container.Nodes;
+      Node  : constant Count_Type := Nodes (Position.Node).Next;
+   begin
+      if Position.Node = Object.Container.Last then
+         return No_Element;
+      else
+         return (Object.Container, Node);
+      end if;
+   end Next;
+
    -------------
    -- Prepend --
    -------------
@@ -1175,6 +1242,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
       end;
    end Previous;
 
+   function Previous
+     (Object   : Iterator;
+      Position : Cursor) return Cursor
+   is
+      Nodes : Node_Array renames Position.Container.Nodes;
+      Node  : constant Count_Type := Nodes (Position.Node).Prev;
+   begin
+      if Position.Node = 0 then
+         return No_Element;
+      else
+         return (Object.Container, Node);
+      end if;
+   end Previous;
+
    -------------------
    -- Query_Element --
    -------------------
@@ -1257,6 +1338,52 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
       raise Program_Error with "attempt to stream list cursor";
    end Read;
 
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Read;
+
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Constant_Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Read;
+
+   ---------------
+   -- Reference --
+   ---------------
+
+   function Constant_Reference (Container : List; Position : Cursor)
+   return Constant_Reference_Type is
+   begin
+      pragma Unreferenced (Container);
+
+      if Position.Container = null then
+         raise Constraint_Error with "Position cursor has no element";
+      end if;
+
+      return (Element =>
+         Position.Container.Nodes (Position.Node).Element'Unrestricted_Access);
+   end Constant_Reference;
+
+   function Reference (Container : List; Position : Cursor)
+   return Reference_Type is
+   begin
+      pragma Unreferenced (Container);
+
+      if Position.Container = null then
+         raise Constraint_Error with "Position cursor has no element";
+      end if;
+
+      return (Element =>
+         Position.Container.Nodes (Position.Node).Element'Unrestricted_Access);
+   end Reference;
+
    ---------------------
    -- Replace_Element --
    ---------------------
@@ -2001,4 +2128,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
       raise Program_Error with "attempt to stream list cursor";
    end Write;
 
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Write;
+
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Constant_Reference_Type)
+   is
+   begin
+      raise Program_Error with "attempt to stream reference";
+   end Write;
+
 end Ada.Containers.Bounded_Doubly_Linked_Lists;
diff --git a/gcc/ada/a-cbdlli.ads b/gcc/ada/a-cbdlli.ads
index 2e5d96cd58d..32e992fa60d 100644
--- a/gcc/ada/a-cbdlli.ads
+++ b/gcc/ada/a-cbdlli.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -31,7 +31,8 @@
 -- This unit was originally developed by Matthew J Heaney.                  --
 ------------------------------------------------------------------------------
 
-private with Ada.Streams;
+with Ada.Streams; use Ada.Streams;
+with Ada.Iterator_Interfaces;
 
 generic
    type Element_Type is private;
@@ -43,7 +44,13 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
    pragma Pure;
    pragma Remote_Types;
 
-   type List (Capacity : Count_Type) is tagged private;
+   type List (Capacity : Count_Type) is tagged private
+   with
+      Constant_Indexing => Constant_Reference,
+      Variable_Indexing => Reference,
+      Default_Iterator  => Iterate,
+      Iterator_Element  => Element_Type;
+
    pragma Preelaborable_Initialization (List);
 
    type Cursor is private;
@@ -52,6 +59,10 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
    Empty_List : constant List;
 
    No_Element : constant Cursor;
+   function Has_Element (Position : Cursor) return Boolean;
+
+   package List_Iterator_Interfaces is new
+     Ada.Iterator_Interfaces (Cursor, Has_Element);
 
    function "=" (Left, Right : List) return Boolean;
 
@@ -129,6 +140,12 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
 
    procedure Reverse_Elements (Container : in out List);
 
+   function Iterate (Container : List)
+      return List_Iterator_Interfaces.Reversible_Iterator'class;
+
+   function Iterate (Container : List; Start : Cursor)
+      return List_Iterator_Interfaces.Reversible_Iterator'class;
+
    procedure Swap
      (Container : in out List;
       I, J      : Cursor);
@@ -183,8 +200,6 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
      (Container : List;
       Item      : Element_Type) return Boolean;
 
-   function Has_Element (Position : Cursor) return Boolean;
-
    procedure Iterate
      (Container : List;
       Process   : not null access procedure (Position : Cursor));
@@ -205,6 +220,48 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
 
    end Generic_Sorting;
 
+   type Constant_Reference_Type
+      (Element : not null access constant Element_Type) is private
+   with
+      Implicit_Dereference => Element;
+
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Constant_Reference_Type);
+
+   for Constant_Reference_Type'Write use Write;
+
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Constant_Reference_Type);
+
+   for Constant_Reference_Type'Read use Read;
+
+   type Reference_Type (Element : not null access Element_Type) is
+   private
+   with
+      Implicit_Dereference => Element;
+
+   procedure Write
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : Reference_Type);
+
+   for Reference_Type'Write use Write;
+
+   procedure Read
+     (Stream : not null access Root_Stream_Type'Class;
+      Item   : out Reference_Type);
+
+   for Reference_Type'Read use Read;
+
+   function Constant_Reference
+     (Container : List; Position : Cursor)    --  SHOULD BE ALIASED
+   return Constant_Reference_Type;
+
+   function Reference
+     (Container : List; Position : Cursor)    --  SHOULD BE ALIASED
+   return Reference_Type;
+
 private
 
    pragma Inline (Next);
@@ -228,8 +285,6 @@ private
       Lock   : Natural := 0;
    end record;
 
-   use Ada.Streams;
-
    procedure Read
      (Stream : not null access Root_Stream_Type'Class;
       Item   : out List);
@@ -263,6 +318,12 @@ private
 
    for Cursor'Write use Write;
 
+   type Constant_Reference_Type
+      (Element : not null access constant Element_Type) is null record;
+
+   type Reference_Type
+      (Element : not null access Element_Type) is null record;
+
    Empty_List : constant List := (Capacity => 0, others => <>);
 
    No_Element : constant Cursor := Cursor'(null, 0);
diff --git a/gcc/ada/a-crbltr.ads b/gcc/ada/a-crbltr.ads
index 30ceff71cc9..2991d36ee06 100644
--- a/gcc/ada/a-crbltr.ads
+++ b/gcc/ada/a-crbltr.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -53,6 +53,13 @@ package Ada.Containers.Red_Black_Trees is
    package Generic_Bounded_Tree_Types is
       type Nodes_Type is array (Count_Type range <>) of Node_Type;
 
+      --  Note that objects of type Tree_Type are logically initialized (in the
+      --  sense that representation invariants of type are satisfied by dint of
+      --  default initialization), even without the Nodes component also having
+      --  its own initialization expression. We only initializae the Nodes
+      --  component here in order to prevent spurious compiler warnings about
+      --  the container object not being fully initialized.
+
       type Tree_Type (Capacity : Count_Type) is tagged record
          First  : Count_Type := 0;
          Last   : Count_Type := 0;
@@ -61,7 +68,7 @@ package Ada.Containers.Red_Black_Trees is
          Busy   : Natural := 0;
          Lock   : Natural := 0;
          Free   : Count_Type'Base := -1;
-         Nodes  : Nodes_Type (1 .. Capacity);
+         Nodes  : Nodes_Type (1 .. Capacity) := (others => <>);
       end record;
    end Generic_Bounded_Tree_Types;
 
diff --git a/gcc/ada/a-rbtgbo.adb b/gcc/ada/a-rbtgbo.adb
index 60a84a0c397..4442d5c63a9 100644
--- a/gcc/ada/a-rbtgbo.adb
+++ b/gcc/ada/a-rbtgbo.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -586,6 +586,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is
          Set_Element (N (Node));
          Tree.Free := Tree.Free - 1;
       end if;
+
+      Set_Parent (N (Node), Parent => 0);
+      Set_Left (N (Node), Left => 0);
+      Set_Right (N (Node), Right => 0);
    end Generic_Allocate;
 
    -------------------
diff --git a/gcc/ada/exp_alfa.ads b/gcc/ada/exp_alfa.ads
index 0e882bef98d..a5c07864be1 100644
--- a/gcc/ada/exp_alfa.ads
+++ b/gcc/ada/exp_alfa.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--             Copyright (C) 2011, Free Software Foundation, Inc.           --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 329f7791d2c..54dea9ad5e0 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -3012,7 +3012,6 @@ package body Exp_Ch5 is
             Name_Step    : Name_Id;
 
          begin
-
             --  The type of the iterator is the return type of the Iterate
             --  function used. For the "of" form this is the default iterator
             --  for the type, otherwise it is the type of the explicit
@@ -3023,6 +3022,7 @@ package body Exp_Ch5 is
             --  use-visible, so we introduce the name of the enclosing package
             --  in the declarations below. The Iterator type is declared in a
             --  an instance within the container package itself.
+
             --  If the container type is a derived type, the cursor type is
             --  found in the package of the parent type.
 
@@ -3034,6 +3034,7 @@ package body Exp_Ch5 is
                else
                   Pack := Scope (Scope (Container_Typ));
                end if;
+
             else
                if Is_Derived_Type (Container_Typ) then
                   Pack := Scope (Root_Type (Container_Typ));
diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb
index 6f1f393d7da..81331eb4b1a 100644
--- a/gcc/ada/lib-xref-alfa.adb
+++ b/gcc/ada/lib-xref-alfa.adb
@@ -594,7 +594,8 @@ package body Alfa is
 
          function Is_Alfa_Reference
            (E   : Entity_Id;
-            Typ : Character) return Boolean is
+            Typ : Character) return Boolean
+         is
          begin
             --  The only references of interest on callable entities are calls.
             --  On non-callable entities, the only references of interest are
diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads
index 5cb84fb50dd..5f39c24a071 100644
--- a/gcc/ada/prj.ads
+++ b/gcc/ada/prj.ads
@@ -580,8 +580,10 @@ package Prj is
                            Include_Compatible_Languages => No_Name_List,
                            Compiler_Driver              => No_File,
                            Compiler_Driver_Path         => null,
-                           Compiler_Leading_Required_Switches  => No_Name_List,
-                           Compiler_Trailing_Required_Switches => No_Name_List,
+                           Compiler_Leading_Required_Switches
+                                                        => No_Name_List,
+                           Compiler_Trailing_Required_Switches
+                                                        => No_Name_List,
                            Multi_Unit_Switches          => No_Name_List,
                            Multi_Unit_Object_Separator  => ' ',
                            Path_Syntax                  => Canonical,
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index cf93ec76301..4b2e0c236a3 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -3860,7 +3860,7 @@ package body Sem_Attr is
             end if;
          end Check_Local;
 
-         --  The attribute ppears within a pre/postcondition, but refers to
+         --  The attribute appears within a pre/postcondition, but refers to
          --  an entity in the enclosing subprogram. If it is a component of a
          --  formal its expansion might generate actual subtypes that may be
          --  referenced in an inner context, and which must be elaborated
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index ad6d482e765..d759defb66f 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -519,19 +519,11 @@ package body Sem_Ch12 is
    procedure Insert_Freeze_Node_For_Instance
      (N      : Node_Id;
       F_Node : Node_Id);
-   --  N is an instance and F_Node is its corresponding freeze node. Insert
-   --  F_Node depending on the enclosing context and placement of N in the
-   --  following manner:
-   --
-   --    1) N is a package instance - Attempt to insert the freeze node before
-   --    a source package or subprogram body which follows immediately after N.
-   --    If no such body is found, perform the actions in 2).
-   --
-   --    2) N is a subprogram instance or a package instance not followed by
-   --    a source body - Insert the freeze node at the end of the declarations
-   --    list which contains N. If N is in the visible part of an enclosing
-   --    package declaration, the freeze node is inserted at the end of the
-   --    private declarations.
+   --  N denotes a package or a subprogram instantiation and F_Node is the
+   --  associated freeze node. Insert the freeze node before the first source
+   --  body which follows immediately after N. If no such body is found, the
+   --  freeze node is inserted at the end of the declarative region which
+   --  contains N.
 
    procedure Freeze_Subprogram_Body
      (Inst_Node : Node_Id;
@@ -7586,7 +7578,6 @@ package body Sem_Ch12 is
             elsif Nkind (Parent (N)) = N_Package_Body
               and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N))
             then
-
                declare
                   Enclosing : constant Entity_Id :=
                                 Corresponding_Spec (Parent (N));
@@ -7596,7 +7587,30 @@ package body Sem_Ch12 is
                   Ensure_Freeze_Node (Enclosing);
 
                   if not Is_List_Member (Freeze_Node (Enclosing)) then
-                     Insert_After (Freeze_Node (Par), Freeze_Node (Enclosing));
+
+                     --  The enclosing context is a subunit, insert the freeze
+                     --  node after the stub.
+
+                     if Nkind (Parent (Parent (N))) = N_Subunit then
+                        Insert_Freeze_Node_For_Instance
+                          (Corresponding_Stub (Parent (Parent (N))),
+                           Freeze_Node (Enclosing));
+
+                     --  The parent instance has been frozen before the body of
+                     --  the enclosing package, insert the freeze node after
+                     --  the body.
+
+                     elsif List_Containing (Freeze_Node (Par)) =
+                           List_Containing (Parent (N))
+                       and then Sloc (Freeze_Node (Par)) < Sloc (Parent (N))
+                     then
+                        Insert_Freeze_Node_For_Instance
+                          (Parent (N), Freeze_Node (Enclosing));
+
+                     else
+                        Insert_After
+                          (Freeze_Node (Par), Freeze_Node (Enclosing));
+                     end if;
                   end if;
                end;
 
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 2745389599a..f26c6ee687d 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -276,11 +276,16 @@ package body Sem_Ch4 is
    --  subprogram, and the call F (X) interpreted as F.all (X). In this case
    --  the call may be overloaded with both interpretations.
 
-   function Try_Object_Operation (N : Node_Id) return Boolean;
+   function Try_Object_Operation
+     (N : Node_Id; CW_Test_Only : Boolean := False) return Boolean;
    --  Ada 2005 (AI-252): Support the object.operation notation. If node N
    --  is a call in this notation, it is transformed into a normal subprogram
    --  call where the prefix is a parameter, and True is returned. If node
-   --  N is not of this form, it is unchanged, and False is returned.
+   --  N is not of this form, it is unchanged, and False is returned. if
+   --  CW_Test_Only is true then N is an N_Selected_Component node which
+   --  is part of a call to an entry or procedure of a tagged concurrent
+   --  type and this routine is invoked to search for class-wide subprograms
+   --  conflicting with the target entity.
 
    procedure wpo (T : Entity_Id);
    pragma Warnings (Off, wpo);
@@ -4165,6 +4170,25 @@ package body Sem_Ch4 is
             then
                return;
             end if;
+
+            --  Ada 2012 (AI05-0090-1): If we found a candidate of a call to an
+            --  entry or procedure of a tagged concurrent type we must check
+            --  if there are class-wide subprograms covering the primitive. If
+            --  true then Try_Object_Operation reports the error.
+
+            if Has_Candidate
+              and then Is_Concurrent_Type (Prefix_Type)
+              and then Nkind (Parent (N)) = N_Procedure_Call_Statement
+
+               --  Duplicate the call. This is required to avoid problems with
+               --  the tree transformations performed by Try_Object_Operation.
+
+              and then Try_Object_Operation
+                         (N => Sinfo.Name (New_Copy_Tree (Parent (N))),
+                          CW_Test_Only => True)
+            then
+               return;
+            end if;
          end if;
 
          if Etype (N) = Any_Type and then Is_Protected_Type (Prefix_Type) then
@@ -6609,7 +6633,9 @@ package body Sem_Ch4 is
    -- Try_Object_Operation --
    --------------------------
 
-   function Try_Object_Operation (N : Node_Id) return Boolean is
+   function Try_Object_Operation
+     (N : Node_Id; CW_Test_Only : Boolean := False) return Boolean
+   is
       K              : constant Node_Kind  := Nkind (Parent (N));
       Is_Subprg_Call : constant Boolean    := Nkind_In
                                                (K, N_Procedure_Call_Statement,
@@ -6898,14 +6924,17 @@ package body Sem_Ch4 is
       ----------------------
 
       procedure Report_Ambiguity (Op : Entity_Id) is
-         Access_Formal : constant Boolean :=
-                           Is_Access_Type (Etype (First_Formal (Op)));
          Access_Actual : constant Boolean :=
                            Is_Access_Type (Etype (Prefix (N)));
+         Access_Formal : Boolean := False;
 
       begin
          Error_Msg_Sloc := Sloc (Op);
 
+         if Present (First_Formal (Op)) then
+            Access_Formal := Is_Access_Type (Etype (First_Formal (Op)));
+         end if;
+
          if Access_Formal and then not Access_Actual then
             if Nkind (Parent (Op)) = N_Full_Type_Declaration then
                Error_Msg_N
@@ -7205,6 +7234,13 @@ package body Sem_Ch4 is
       --  Start of processing for Try_Class_Wide_Operation
 
       begin
+         --  If we are searching only for conflicting class-wide subprograms
+         --  then initialize directly Matching_Op with the target entity.
+
+         if CW_Test_Only then
+            Matching_Op := Entity (Selector_Name (N));
+         end if;
+
          --  Loop through ancestor types (including interfaces), traversing
          --  the homonym chain of the subprogram, trying out those homonyms
          --  whose first formal has the class-wide type of the ancestor, or
@@ -7286,10 +7322,12 @@ package body Sem_Ch4 is
             pragma Unreferenced (CW_Result);
 
          begin
-            Prim_Result :=
-              Try_Primitive_Operation
-                (Call_Node       => New_Call_Node,
-                 Node_To_Replace => Node_To_Replace);
+            if not CW_Test_Only then
+               Prim_Result :=
+                  Try_Primitive_Operation
+                   (Call_Node       => New_Call_Node,
+                    Node_To_Replace => Node_To_Replace);
+            end if;
 
             --  Check if there is a class-wide subprogram covering the
             --  primitive. This check must be done even if a candidate
@@ -7663,10 +7701,18 @@ package body Sem_Ch4 is
       end if;
 
       if Etype (New_Call_Node) /= Any_Type then
-         Complete_Object_Operation
-           (Call_Node       => New_Call_Node,
-            Node_To_Replace => Node_To_Replace);
-         return True;
+
+         --  No need to complete the tree transformations if we are only
+         --  searching for conflicting class-wide subprograms
+
+         if CW_Test_Only then
+            return False;
+         else
+            Complete_Object_Operation
+              (Call_Node       => New_Call_Node,
+               Node_To_Replace => Node_To_Replace);
+            return True;
+         end if;
 
       elsif Present (Candidate) then