sem_cat.adb (Validate_RCI_Subprogram_Declaration): Add tests of Has_Stream_Attribute_ Definition when...

2008-04-08  Gary Dismukes  <dismukes@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* sem_cat.adb (Validate_RCI_Subprogram_Declaration): Add tests of
	Has_Stream_Attribute_ Definition when checking for available stream
	attributes on parameters of a limited type in Ada 2005. Necessary for
	proper recognition of visible stream attribute clauses.
	(Has_Stream_Attribute_Definition): If the type is derived from a
	private type, then use the derived type's underlying type for checking
	whether it has stream attributes.
	(Validate_Object_Declaration): The check for a user-defined Initialize
	procedure applies also to types with controlled components or a
	controlled ancestor.
	Reject an object declaration in a preelaborated unit if the type is a
	controlled type with an overriding Initialize procedure.
	(Validate_Remote_Access_To_Class_Wide_Type): Return without further
	checking when the parent of a dereference is a selected component and
	the name has not been analyzed.

	* sem_ch4.adb (Analyze_Selected_Component): Add checking for selected
	prefixes that are invalid explicit dereferences of remote
	access-to-class-wide values, first checking whether the selected
	component is a prefixed form of call to a tagged operation.
	(Analyze_Call): Remove code that issues an error for limited function
	calls in illegal contexts, as we now support all of the contexts that
	were forbidden here.
	Allow a function call that returns a task.and appears as the
	prefix of a selected component.
	(Analyze_Reference): Give error message if we try to make a 'Reference
	for an object that is atomic/aliased without its type having the
	corresponding attribute.
	(Analyze_Call): Remove condition checking for attributes to allow
	calls to functions with inherently limited results as prefixes of
	attributes. Remove related comment about Class attributes.
	(Analyze_Selected_Component): If the prefix is a remote type, check
	whether this is a prefixed call before reporting an error.
	(Complete_Object_Operation): If the controlling formal is an access to
	variable reject an actual that is a constant or an access to one.
	(Try_Object_Operation): If prefix is a tagged protected object,retrieve
	primitive operations from base type.

	* exp_ch4.adb (Expand_N_Indexed_Component): Test for prefix that is a
	build-in-place
	function call and call Make_Build_In_Place_Call_In_Anonymous_Context.
	(Expand_N_Selected_Component): Test for prefix that is a build-in-place
	function call and call Make_Build_In_Place_Call_In_Anonymous_Context.
	(Expand_N_Slice): Test for prefix that is a build-in-place function call
	and call Make_Build_In_Place_Call_In_Anonymous_Context.
	(Analyze_Call): Remove code that issues an error for limited function
	calls in illegal contexts, as we now support all of the contexts that
	were forbidden here.
	New calling sequence for Get_Simple_Init_Val
	(Expand_Boolean_Operator): Add call to Silly_Boolean_Array_Xor_Test
	(Expand_N_Op_Not): Add call to Silly_Boolan_Array_Not_Test

From-SVN: r134026

3 files changed, 497 insertions, 325 deletions

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 0473fc0..ee440f1 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -1852,6 +1852,10 @@ package body Exp_Ch4 is
          Ensure_Defined (Etype (R), N);
          Apply_Length_Check (R, Etype (L));
 
+         if Nkind (N) = N_Op_Xor then
+            Silly_Boolean_Array_Xor_Test (N, Etype (L));
+         end if;
+
          if Nkind (Parent (N)) = N_Assignment_Statement
            and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
          then
@@ -1860,7 +1864,7 @@ package body Exp_Ch4 is
          elsif Nkind (Parent (N)) = N_Op_Not
            and then Nkind (N) = N_Op_And
            and then
-         Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
+             Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
          then
             return;
          else
@@ -2812,7 +2816,7 @@ package body Exp_Ch4 is
 
          function Needs_Initialization_Call (N : Node_Id) return Boolean;
          --  Determine whether node N is a subtype indicator allocator which
-         --  asts a coextension. Such coextensions need initialization.
+         --  acts a coextension. Such coextensions need initialization.
 
          -------------------------------
          -- Inside_A_Return_Statement --
@@ -2943,27 +2947,34 @@ package body Exp_Ch4 is
                Ref := New_Copy_Tree (Coext);
             end if;
 
-            --  Generate:
-            --    initialize (Ref)
-            --    attach_to_final_list (Ref, Flist, 2)
+            --  No initialization call if not allowed
 
-            if Needs_Initialization_Call (Coext) then
-               Insert_Actions (N,
-                 Make_Init_Call (
-                   Ref         => Ref,
-                   Typ         => Etype (Coext),
-                   Flist_Ref   => Flist,
-                   With_Attach => Make_Integer_Literal (Loc, Uint_2)));
+            Check_Restriction (No_Default_Initialization, N);
 
-            --  Generate:
-            --    attach_to_final_list (Ref, Flist, 2)
+            if not Restriction_Active (No_Default_Initialization) then
 
-            else
-               Insert_Action (N,
-                 Make_Attach_Call (
-                   Obj_Ref     => Ref,
-                   Flist_Ref   => New_Copy_Tree (Flist),
-                   With_Attach => Make_Integer_Literal (Loc, Uint_2)));
+               --  Generate:
+               --    initialize (Ref)
+               --    attach_to_final_list (Ref, Flist, 2)
+
+               if Needs_Initialization_Call (Coext) then
+                  Insert_Actions (N,
+                    Make_Init_Call (
+                      Ref         => Ref,
+                      Typ         => Etype (Coext),
+                      Flist_Ref   => Flist,
+                      With_Attach => Make_Integer_Literal (Loc, Uint_2)));
+
+               --  Generate:
+               --    attach_to_final_list (Ref, Flist, 2)
+
+               else
+                  Insert_Action (N,
+                    Make_Attach_Call (
+                      Obj_Ref     => Ref,
+                      Flist_Ref   => New_Copy_Tree (Flist),
+                      With_Attach => Make_Integer_Literal (Loc, Uint_2)));
+               end if;
             end if;
 
             Next_Elmt (Coext_Elmt);
@@ -3174,10 +3185,11 @@ package body Exp_Ch4 is
             --  Case of simple initialization required
 
             if Needs_Simple_Initialization (T) then
+               Check_Restriction (No_Default_Initialization, N);
                Rewrite (Expression (N),
                  Make_Qualified_Expression (Loc,
                    Subtype_Mark => New_Occurrence_Of (T, Loc),
-                   Expression   => Get_Simple_Init_Val (T, Loc)));
+                   Expression   => Get_Simple_Init_Val (T, N)));
 
                Analyze_And_Resolve (Expression (Expression (N)), T);
                Analyze_And_Resolve (Expression (N), T);
@@ -3193,292 +3205,299 @@ package body Exp_Ch4 is
          --  Case of initialization procedure present, must be called
 
          else
-            Init := Base_Init_Proc (T);
-            Nod  := N;
-            Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
-
-            --  Construct argument list for the initialization routine call
-
-            Arg1 :=
-              Make_Explicit_Dereference (Loc,
-                Prefix => New_Reference_To (Temp, Loc));
-            Set_Assignment_OK (Arg1);
-            Temp_Type := PtrT;
+            Check_Restriction (No_Default_Initialization, N);
 
-            --  The initialization procedure expects a specific type. if the
-            --  context is access to class wide, indicate that the object being
-            --  allocated has the right specific type.
+            if not Restriction_Active (No_Default_Initialization) then
+               Init := Base_Init_Proc (T);
+               Nod  := N;
+               Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 
-            if Is_Class_Wide_Type (Dtyp) then
-               Arg1 := Unchecked_Convert_To (T, Arg1);
-            end if;
-
-            --  If designated type is a concurrent type or if it is private
-            --  type whose definition is a concurrent type, the first argument
-            --  in the Init routine has to be unchecked conversion to the
-            --  corresponding record type. If the designated type is a derived
-            --  type, we also convert the argument to its root type.
-
-            if Is_Concurrent_Type (T) then
-               Arg1 :=
-                 Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
+               --  Construct argument list for the initialization routine call
 
-            elsif Is_Private_Type (T)
-              and then Present (Full_View (T))
-              and then Is_Concurrent_Type (Full_View (T))
-            then
                Arg1 :=
-                 Unchecked_Convert_To
-                   (Corresponding_Record_Type (Full_View (T)), Arg1);
-
-            elsif Etype (First_Formal (Init)) /= Base_Type (T) then
-               declare
-                  Ftyp : constant Entity_Id := Etype (First_Formal (Init));
+                 Make_Explicit_Dereference (Loc,
+                   Prefix => New_Reference_To (Temp, Loc));
+               Set_Assignment_OK (Arg1);
+               Temp_Type := PtrT;
 
-               begin
-                  Arg1 := OK_Convert_To (Etype (Ftyp), Arg1);
-                  Set_Etype (Arg1, Ftyp);
-               end;
-            end if;
+               --  The initialization procedure expects a specific type. if the
+               --  context is access to class wide, indicate that the object
+               --  being allocated has the right specific type.
 
-            Args := New_List (Arg1);
+               if Is_Class_Wide_Type (Dtyp) then
+                  Arg1 := Unchecked_Convert_To (T, Arg1);
+               end if;
 
-            --  For the task case, pass the Master_Id of the access type as
-            --  the value of the _Master parameter, and _Chain as the value
-            --  of the _Chain parameter (_Chain will be defined as part of
-            --  the generated code for the allocator).
+               --  If designated type is a concurrent type or if it is private
+               --  type whose definition is a concurrent type, the first
+               --  argument in the Init routine has to be unchecked conversion
+               --  to the corresponding record type. If the designated type is
+               --  a derived type, we also convert the argument to its root
+               --  type.
 
-            --  In Ada 2005, the context may be a function that returns an
-            --  anonymous access type. In that case the Master_Id has been
-            --  created when expanding the function declaration.
+               if Is_Concurrent_Type (T) then
+                  Arg1 :=
+                    Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
 
-            if Has_Task (T) then
-               if No (Master_Id (Base_Type (PtrT))) then
+               elsif Is_Private_Type (T)
+                 and then Present (Full_View (T))
+                 and then Is_Concurrent_Type (Full_View (T))
+               then
+                  Arg1 :=
+                    Unchecked_Convert_To
+                      (Corresponding_Record_Type (Full_View (T)), Arg1);
 
-                  --  If we have a non-library level task with the restriction
-                  --  No_Task_Hierarchy set, then no point in expanding.
+               elsif Etype (First_Formal (Init)) /= Base_Type (T) then
+                  declare
+                     Ftyp : constant Entity_Id := Etype (First_Formal (Init));
+                  begin
+                     Arg1 := OK_Convert_To (Etype (Ftyp), Arg1);
+                     Set_Etype (Arg1, Ftyp);
+                  end;
+               end if;
 
-                  if not Is_Library_Level_Entity (T)
-                    and then Restriction_Active (No_Task_Hierarchy)
-                  then
-                     return;
-                  end if;
+               Args := New_List (Arg1);
 
-                  --  The designated type was an incomplete type, and the
-                  --  access type did not get expanded. Salvage it now.
+               --  For the task case, pass the Master_Id of the access type as
+               --  the value of the _Master parameter, and _Chain as the value
+               --  of the _Chain parameter (_Chain will be defined as part of
+               --  the generated code for the allocator).
 
-                  pragma Assert (Present (Parent (Base_Type (PtrT))));
-                  Expand_N_Full_Type_Declaration (Parent (Base_Type (PtrT)));
-               end if;
+               --  In Ada 2005, the context may be a function that returns an
+               --  anonymous access type. In that case the Master_Id has been
+               --  created when expanding the function declaration.
 
-               --  If the context of the allocator is a declaration or an
-               --  assignment, we can generate a meaningful image for it,
-               --  even though subsequent assignments might remove the
-               --  connection between task and entity. We build this image
-               --  when the left-hand side is a simple variable, a simple
-               --  indexed assignment or a simple selected component.
+               if Has_Task (T) then
+                  if No (Master_Id (Base_Type (PtrT))) then
 
-               if Nkind (Parent (N)) = N_Assignment_Statement then
-                  declare
-                     Nam : constant Node_Id := Name (Parent (N));
+                     --  If we have a non-library level task with restriction
+                     --  No_Task_Hierarchy set, then no point in expanding.
 
-                  begin
-                     if Is_Entity_Name (Nam) then
-                        Decls :=
-                          Build_Task_Image_Decls (
-                            Loc,
-                              New_Occurrence_Of
-                                (Entity (Nam), Sloc (Nam)), T);
-
-                     elsif Nkind_In
-                             (Nam, N_Indexed_Component, N_Selected_Component)
-                       and then Is_Entity_Name (Prefix (Nam))
+                     if not Is_Library_Level_Entity (T)
+                       and then Restriction_Active (No_Task_Hierarchy)
                      then
-                        Decls :=
-                          Build_Task_Image_Decls
-                            (Loc, Nam, Etype (Prefix (Nam)));
-                     else
-                        Decls := Build_Task_Image_Decls (Loc, T, T);
+                        return;
                      end if;
-                  end;
 
-               elsif Nkind (Parent (N)) = N_Object_Declaration then
-                  Decls :=
-                    Build_Task_Image_Decls (
-                       Loc, Defining_Identifier (Parent (N)), T);
+                     --  The designated type was an incomplete type, and the
+                     --  access type did not get expanded. Salvage it now.
 
-               else
-                  Decls := Build_Task_Image_Decls (Loc, T, T);
-               end if;
-
-               Append_To (Args,
-                 New_Reference_To
-                   (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
-               Append_To (Args, Make_Identifier (Loc, Name_uChain));
+                     pragma Assert (Present (Parent (Base_Type (PtrT))));
+                     Expand_N_Full_Type_Declaration
+                       (Parent (Base_Type (PtrT)));
+                  end if;
 
-               Decl := Last (Decls);
-               Append_To (Args,
-                 New_Occurrence_Of (Defining_Identifier (Decl), Loc));
+                  --  If the context of the allocator is a declaration or an
+                  --  assignment, we can generate a meaningful image for it,
+                  --  even though subsequent assignments might remove the
+                  --  connection between task and entity. We build this image
+                  --  when the left-hand side is a simple variable, a simple
+                  --  indexed assignment or a simple selected component.
+
+                  if Nkind (Parent (N)) = N_Assignment_Statement then
+                     declare
+                        Nam : constant Node_Id := Name (Parent (N));
+
+                     begin
+                        if Is_Entity_Name (Nam) then
+                           Decls :=
+                             Build_Task_Image_Decls
+                               (Loc,
+                                New_Occurrence_Of
+                                  (Entity (Nam), Sloc (Nam)), T);
+
+                        elsif Nkind_In
+                          (Nam, N_Indexed_Component, N_Selected_Component)
+                          and then Is_Entity_Name (Prefix (Nam))
+                        then
+                           Decls :=
+                             Build_Task_Image_Decls
+                               (Loc, Nam, Etype (Prefix (Nam)));
+                        else
+                           Decls := Build_Task_Image_Decls (Loc, T, T);
+                        end if;
+                     end;
 
-            --  Has_Task is false, Decls not used
+                  elsif Nkind (Parent (N)) = N_Object_Declaration then
+                     Decls :=
+                       Build_Task_Image_Decls
+                         (Loc, Defining_Identifier (Parent (N)), T);
 
-            else
-               Decls := No_List;
-            end if;
+                  else
+                     Decls := Build_Task_Image_Decls (Loc, T, T);
+                  end if;
 
-            --  Add discriminants if discriminated type
+                  Append_To (Args,
+                    New_Reference_To
+                      (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
+                  Append_To (Args, Make_Identifier (Loc, Name_uChain));
 
-            declare
-               Dis : Boolean := False;
-               Typ : Entity_Id;
+                  Decl := Last (Decls);
+                  Append_To (Args,
+                    New_Occurrence_Of (Defining_Identifier (Decl), Loc));
 
-            begin
-               if Has_Discriminants (T) then
-                  Dis := True;
-                  Typ := T;
+                  --  Has_Task is false, Decls not used
 
-               elsif Is_Private_Type (T)
-                 and then Present (Full_View (T))
-                 and then Has_Discriminants (Full_View (T))
-               then
-                  Dis := True;
-                  Typ := Full_View (T);
+               else
+                  Decls := No_List;
                end if;
 
-               if Dis then
-                  --  If the allocated object will be constrained by the
-                  --  default values for discriminants, then build a
-                  --  subtype with those defaults, and change the allocated
-                  --  subtype to that. Note that this happens in fewer
-                  --  cases in Ada 2005 (AI-363).
-
-                  if not Is_Constrained (Typ)
-                    and then Present (Discriminant_Default_Value
-                                       (First_Discriminant (Typ)))
-                    and then (Ada_Version < Ada_05
-                               or else not Has_Constrained_Partial_View (Typ))
+               --  Add discriminants if discriminated type
+
+               declare
+                  Dis : Boolean := False;
+                  Typ : Entity_Id;
+
+               begin
+                  if Has_Discriminants (T) then
+                     Dis := True;
+                     Typ := T;
+
+                  elsif Is_Private_Type (T)
+                    and then Present (Full_View (T))
+                    and then Has_Discriminants (Full_View (T))
                   then
-                     Typ := Build_Default_Subtype (Typ, N);
-                     Set_Expression (N, New_Reference_To (Typ, Loc));
+                     Dis := True;
+                     Typ := Full_View (T);
                   end if;
 
-                  Discr := First_Elmt (Discriminant_Constraint (Typ));
-                  while Present (Discr) loop
-                     Nod := Node (Discr);
-                     Append (New_Copy_Tree (Node (Discr)), Args);
+                  if Dis then
 
-                     --  AI-416: when the discriminant constraint is an
-                     --  anonymous access type make sure an accessibility
-                     --  check is inserted if necessary (3.10.2(22.q/2))
+                     --  If the allocated object will be constrained by the
+                     --  default values for discriminants, then build a
+                     --  subtype with those defaults, and change the allocated
+                     --  subtype to that. Note that this happens in fewer
+                     --  cases in Ada 2005 (AI-363).
 
-                     if Ada_Version >= Ada_05
-                       and then Ekind (Etype (Nod)) = E_Anonymous_Access_Type
+                     if not Is_Constrained (Typ)
+                       and then Present (Discriminant_Default_Value
+                                         (First_Discriminant (Typ)))
+                       and then (Ada_Version < Ada_05
+                                  or else
+                                    not Has_Constrained_Partial_View (Typ))
                      then
-                        Apply_Accessibility_Check (Nod, Typ);
+                        Typ := Build_Default_Subtype (Typ, N);
+                        Set_Expression (N, New_Reference_To (Typ, Loc));
                      end if;
 
-                     Next_Elmt (Discr);
-                  end loop;
-               end if;
-            end;
+                     Discr := First_Elmt (Discriminant_Constraint (Typ));
+                     while Present (Discr) loop
+                        Nod := Node (Discr);
+                        Append (New_Copy_Tree (Node (Discr)), Args);
 
-            --  We set the allocator as analyzed so that when we analyze the
-            --  expression actions node, we do not get an unwanted recursive
-            --  expansion of the allocator expression.
+                        --  AI-416: when the discriminant constraint is an
+                        --  anonymous access type make sure an accessibility
+                        --  check is inserted if necessary (3.10.2(22.q/2))
 
-            Set_Analyzed (N, True);
-            Nod := Relocate_Node (N);
+                        if Ada_Version >= Ada_05
+                          and then
+                            Ekind (Etype (Nod)) = E_Anonymous_Access_Type
+                        then
+                           Apply_Accessibility_Check (Nod, Typ);
+                        end if;
 
-            --  Here is the transformation:
-            --    input:  new T
-            --    output: Temp : constant ptr_T := new T;
-            --            Init (Temp.all, ...);
-            --    <CTRL>  Attach_To_Final_List (Finalizable (Temp.all));
-            --    <CTRL>  Initialize (Finalizable (Temp.all));
+                        Next_Elmt (Discr);
+                     end loop;
+                  end if;
+               end;
 
-            --  Here ptr_T is the pointer type for the allocator, and is the
-            --  subtype of the allocator.
+               --  We set the allocator as analyzed so that when we analyze the
+               --  expression actions node, we do not get an unwanted recursive
+               --  expansion of the allocator expression.
 
-            Temp_Decl :=
-              Make_Object_Declaration (Loc,
-                Defining_Identifier => Temp,
-                Constant_Present    => True,
-                Object_Definition   => New_Reference_To (Temp_Type, Loc),
-                Expression          => Nod);
+               Set_Analyzed (N, True);
+               Nod := Relocate_Node (N);
 
-            Set_Assignment_OK (Temp_Decl);
-            Insert_Action (N, Temp_Decl, Suppress => All_Checks);
+               --  Here is the transformation:
+               --    input:  new T
+               --    output: Temp : constant ptr_T := new T;
+               --            Init (Temp.all, ...);
+               --    <CTRL>  Attach_To_Final_List (Finalizable (Temp.all));
+               --    <CTRL>  Initialize (Finalizable (Temp.all));
 
-            --  If the designated type is a task type or contains tasks,
-            --  create block to activate created tasks, and insert
-            --  declaration for Task_Image variable ahead of call.
+               --  Here ptr_T is the pointer type for the allocator, and is the
+               --  subtype of the allocator.
 
-            if Has_Task (T) then
-               declare
-                  L   : constant List_Id := New_List;
-                  Blk : Node_Id;
+               Temp_Decl :=
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Temp,
+                   Constant_Present    => True,
+                   Object_Definition   => New_Reference_To (Temp_Type, Loc),
+                   Expression          => Nod);
 
-               begin
-                  Build_Task_Allocate_Block (L, Nod, Args);
-                  Blk := Last (L);
+               Set_Assignment_OK (Temp_Decl);
+               Insert_Action (N, Temp_Decl, Suppress => All_Checks);
 
-                  Insert_List_Before (First (Declarations (Blk)), Decls);
-                  Insert_Actions (N, L);
-               end;
+               --  If the designated type is a task type or contains tasks,
+               --  create block to activate created tasks, and insert
+               --  declaration for Task_Image variable ahead of call.
 
-            else
-               Insert_Action (N,
-                 Make_Procedure_Call_Statement (Loc,
-                   Name => New_Reference_To (Init, Loc),
-                   Parameter_Associations => Args));
-            end if;
+               if Has_Task (T) then
+                  declare
+                     L   : constant List_Id := New_List;
+                     Blk : Node_Id;
+                  begin
+                     Build_Task_Allocate_Block (L, Nod, Args);
+                     Blk := Last (L);
+                     Insert_List_Before (First (Declarations (Blk)), Decls);
+                     Insert_Actions (N, L);
+                  end;
 
-            if Controlled_Type (T) then
+               else
+                  Insert_Action (N,
+                    Make_Procedure_Call_Statement (Loc,
+                      Name                   => New_Reference_To (Init, Loc),
+                      Parameter_Associations => Args));
+               end if;
 
-               --  Postpone the generation of a finalization call for the
-               --  current allocator if it acts as a coextension.
+               if Controlled_Type (T) then
 
-               if Is_Dynamic_Coextension (N) then
-                  if No (Coextensions (N)) then
-                     Set_Coextensions (N, New_Elmt_List);
-                  end if;
+                  --  Postpone the generation of a finalization call for the
+                  --  current allocator if it acts as a coextension.
 
-                  Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N));
+                  if Is_Dynamic_Coextension (N) then
+                     if No (Coextensions (N)) then
+                        Set_Coextensions (N, New_Elmt_List);
+                     end if;
 
-               else
-                  Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
+                     Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N));
+
+                  else
+                     Flist :=
+                       Get_Allocator_Final_List (N, Base_Type (T), PtrT);
 
-                  --  Anonymous access types created for access parameters
-                  --  are attached to an explicitly constructed controller,
-                  --  which ensures that they can be finalized properly, even
-                  --  if their deallocation might not happen. The list
-                  --  associated with the controller is doubly-linked. For
-                  --  other anonymous access types, the object may end up
-                  --  on the global final list which is singly-linked.
-                  --  Work needed for access discriminants in Ada 2005 ???
+                     --  Anonymous access types created for access parameters
+                     --  are attached to an explicitly constructed controller,
+                     --  which ensures that they can be finalized properly,
+                     --  even if their deallocation might not happen. The list
+                     --  associated with the controller is doubly-linked. For
+                     --  other anonymous access types, the object may end up
+                     --  on the global final list which is singly-linked.
+                     --  Work needed for access discriminants in Ada 2005 ???
 
-                  if Ekind (PtrT) = E_Anonymous_Access_Type
+                     if Ekind (PtrT) = E_Anonymous_Access_Type
                        and then
                          Nkind (Associated_Node_For_Itype (PtrT))
-                           not in N_Subprogram_Specification
-                  then
-                     Attach_Level := Uint_1;
-                  else
-                     Attach_Level := Uint_2;
-                  end if;
+                     not in N_Subprogram_Specification
+                     then
+                        Attach_Level := Uint_1;
+                     else
+                        Attach_Level := Uint_2;
+                     end if;
 
-                  Insert_Actions (N,
-                    Make_Init_Call (
-                      Ref          => New_Copy_Tree (Arg1),
-                      Typ          => T,
-                      Flist_Ref    => Flist,
-                      With_Attach  => Make_Integer_Literal
-                                        (Loc, Attach_Level)));
+                     Insert_Actions (N,
+                       Make_Init_Call (
+                         Ref          => New_Copy_Tree (Arg1),
+                         Typ          => T,
+                         Flist_Ref    => Flist,
+                         With_Attach  => Make_Integer_Literal (Loc,
+                                           Intval => Attach_Level)));
+                  end if;
                end if;
-            end if;
 
-            Rewrite (N, New_Reference_To (Temp, Loc));
-            Analyze_And_Resolve (N, PtrT);
+               Rewrite (N, New_Reference_To (Temp, Loc));
+               Analyze_And_Resolve (N, PtrT);
+            end if;
          end if;
       end;
 
@@ -4110,6 +4129,15 @@ package body Exp_Ch4 is
          return;
       end if;
 
+      --  Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
+      --  function, then additional actuals must be passed.
+
+      if Ada_Version >= Ada_05
+        and then Is_Build_In_Place_Function_Call (P)
+      then
+         Make_Build_In_Place_Call_In_Anonymous_Context (P);
+      end if;
+
       --  If the prefix is an access type, then we unconditionally rewrite
       --  if as an explicit deference. This simplifies processing for several
       --  cases, including packed array cases and certain cases in which
@@ -6236,6 +6264,7 @@ package body Exp_Ch4 is
       Convert_To_Actual_Subtype (Opnd);
       Arr := Etype (Opnd);
       Ensure_Defined (Arr, N);
+      Silly_Boolean_Array_Not_Test (N, Arr);
 
       if Nkind (Parent (N)) = N_Assignment_Statement then
          if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
@@ -6758,6 +6787,15 @@ package body Exp_Ch4 is
          Generate_Discriminant_Check (N);
       end if;
 
+      --  Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
+      --  function, then additional actuals must be passed.
+
+      if Ada_Version >= Ada_05
+        and then Is_Build_In_Place_Function_Call (P)
+      then
+         Make_Build_In_Place_Call_In_Anonymous_Context (P);
+      end if;
+
       --  Gigi cannot handle unchecked conversions that are the prefix of a
       --  selected component with discriminants. This must be checked during
       --  expansion, because during analysis the type of the selector is not
@@ -7025,6 +7063,15 @@ package body Exp_Ch4 is
          Analyze_And_Resolve (Pfx, Ptp);
       end if;
 
+      --  Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
+      --  function, then additional actuals must be passed.
+
+      if Ada_Version >= Ada_05
+        and then Is_Build_In_Place_Function_Call (Pfx)
+      then
+         Make_Build_In_Place_Call_In_Anonymous_Context (Pfx);
+      end if;
+
       --  Range checks are potentially also needed for cases involving
       --  a slice indexed by a subtype indication, but Do_Range_Check
       --  can currently only be set for expressions ???
@@ -9072,7 +9119,8 @@ package body Exp_Ch4 is
             --  configurable run time setting.
 
             if not RTE_Available (RE_IW_Membership) then
-               Error_Msg_CRT ("abstract interface types", N);
+               Error_Msg_CRT
+                 ("dynamic membership test on interface types", N);
                return Empty;
             end if;
 
diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb
index b9dbfb1..e790e55 100644
--- a/gcc/ada/sem_cat.adb
+++ b/gcc/ada/sem_cat.adb
@@ -219,7 +219,7 @@ package body Sem_Cat is
             --  unit generating the message is an internal unit. This is the
             --  situation in which such messages would be ignored in any case,
             --  so it is convenient not to generate them (since it causes
-            --  annoying inteference with debugging)
+            --  annoying interference with debugging).
 
             if Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
               and then not Is_Internal_File_Name (Unit_File_Name (Main_Unit))
@@ -332,8 +332,21 @@ package body Sem_Cat is
       Nam          : TSS_Name_Type;
       At_Any_Place : Boolean := False) return Boolean
    is
-      Rep_Item : Node_Id;
+      Rep_Item  : Node_Id;
+      Full_Type : Entity_Id := Typ;
+
    begin
+      --  In the case of a type derived from a private view, any specified
+      --  stream attributes will be attached to the derived type's underlying
+      --  type rather the derived type entity itself (which is itself private).
+
+      if Is_Private_Type (Typ)
+        and then Is_Derived_Type (Typ)
+        and then Present (Full_View (Typ))
+      then
+         Full_Type := Underlying_Type (Typ);
+      end if;
+
       --  We start from the declaration node and then loop until the end of
       --  the list until we find the requested attribute definition clause.
       --  In Ada 2005 mode, clauses are ignored if they are not currently
@@ -341,7 +354,7 @@ package body Sem_Cat is
       --  inserted by the expander at the point where the clause occurs),
       --  unless At_Any_Place is true.
 
-      Rep_Item := First_Rep_Item (Typ);
+      Rep_Item := First_Rep_Item (Full_Type);
       while Present (Rep_Item) loop
          if Nkind (Rep_Item) = N_Attribute_Definition_Clause then
             case Chars (Rep_Item) is
@@ -1251,7 +1264,9 @@ package body Sem_Cat is
             end;
          end if;
 
-         --  Non-static discriminant not allowed in preelaborayted unit
+         --  Non-static discriminant not allowed in preelaborated unit
+         --  Controlled object of a type with a user-defined Initialize
+         --  is forbidden as well.
 
          if Is_Record_Type (Etype (Id)) then
             declare
@@ -1274,7 +1289,14 @@ package body Sem_Cat is
                         PEE);
                   end if;
                end if;
+
+               if Has_Overriding_Initialize (ET) then
+                  Error_Msg_NE
+                    ("controlled type& does not have"
+                      & " preelaborable initialization", N, ET);
+               end if;
             end;
+
          end if;
       end if;
 
@@ -1552,9 +1574,9 @@ package body Sem_Cat is
                       Error_Node);
                end if;
 
-            --  For limited private type parameter, we check only the private
+            --  For a limited private type parameter, we check only the private
             --  declaration and ignore full type declaration, unless this is
-            --  the only declaration for the type, eg. as a limited record.
+            --  the only declaration for the type, e.g., as a limited record.
 
             elsif Is_Limited_Type (Param_Type)
               and then (Nkind (Type_Decl) = N_Private_Type_Declaration
@@ -1569,7 +1591,7 @@ package body Sem_Cat is
                if No (Full_View (Param_Type))
                  and then Ekind (Param_Type) /= E_Record_Type
                then
-                  --  Type does not have completion yet, so if declared in in
+                  --  Type does not have completion yet, so if declared in
                   --  the current RCI scope it is illegal, and will be flagged
                   --  subsequently.
 
@@ -1585,7 +1607,11 @@ package body Sem_Cat is
                --  contract model for privacy, but we support both semantics
                --  for now for compatibility (note that ACATS test BXE2009
                --  checks a case that conforms to the Ada 95 rules but is
-               --  illegal in Ada 2005).
+               --  illegal in Ada 2005). In the Ada 2005 case we check for the
+               --  possibilities of visible TSS stream subprograms or explicit
+               --  stream attribute definitions because the TSS subprograms
+               --  can be hidden in the private part while the attribute
+               --  definitions are still be available from the visible part.
 
                Base_Param_Type := Base_Type (Param_Type);
                Base_Under_Type := Base_Type (Underlying_Type
@@ -1609,7 +1635,13 @@ package body Sem_Cat is
                            or else
                          Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Read))
                            or else
-                         Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Write))))
+                         Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Write)))
+                      and then
+                        (not Has_Stream_Attribute_Definition
+                               (Base_Param_Type, TSS_Stream_Read)
+                           or else
+                         not Has_Stream_Attribute_Definition
+                               (Base_Param_Type, TSS_Stream_Write)))
                then
                   if K = N_Subprogram_Declaration then
                      Error_Node := Param_Spec;
@@ -1761,12 +1793,15 @@ package body Sem_Cat is
 
       --  This subprogram also enforces the checks in E.2.2(13). A value of
       --  such type must not be dereferenced unless as controlling operand of
-      --  a dispatching call.
+      --  a dispatching call. Explicit dereferences not coming from source are
+      --  exempted from this checking because the expander produces them in
+      --  some cases (such as for tag checks on dispatching calls with multiple
+      --  controlling operands). However we do check in the case of an implicit
+      --  dereference that is expanded to an explicit dereference (hence the
+      --  test of whether Original_Node (N) comes from source).
 
       elsif K = N_Explicit_Dereference
-        and then (Comes_From_Source (N)
-                    or else (Nkind (Original_Node (N)) = N_Selected_Component
-                               and then Comes_From_Source (Original_Node (N))))
+        and then Comes_From_Source (Original_Node (N))
       then
          E := Etype (Prefix (N));
 
@@ -1788,9 +1823,12 @@ package body Sem_Cat is
 
          --  If we are just within a procedure or function call and the
          --  dereference has not been analyzed, return because this procedure
-         --  will be called again from sem_res Resolve_Actuals.
+         --  will be called again from sem_res Resolve_Actuals. The same can
+         --  apply in the case of dereference that is the prefix of a selected
+         --  component, which can be a call given in prefixed form.
 
-         if Is_Actual_Parameter (N)
+         if (Is_Actual_Parameter (N)
+              or else PK = N_Selected_Component)
            and then not Analyzed (N)
          then
             return;
@@ -1806,25 +1844,8 @@ package body Sem_Cat is
             return;
          end if;
 
-         --  The following code is needed for expansion of RACW Write
-         --  attribute, since such expressions can appear in the expanded
-         --  code.
-
-         if not Comes_From_Source (N)
-           and then
-           (PK = N_In
-            or else PK = N_Attribute_Reference
-            or else
-              (PK = N_Type_Conversion
-               and then Present (Parent (N))
-               and then Present (Parent (Parent (N)))
-               and then
-                 Nkind (Parent (Parent (N))) = N_Selected_Component))
-         then
-            return;
-         end if;
-
-         Error_Msg_N ("incorrect dereference of remote type", N);
+         Error_Msg_N
+           ("invalid dereference of a remote access-to-class-wide value", N);
       end if;
    end Validate_Remote_Access_To_Class_Wide_Type;
 
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index e3d45f9..2246399 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -73,7 +73,7 @@ package body Sem_Ch4 is
    --  function, and if so must be converted into an explicit call node
    --  and analyzed as such. This deproceduring must be done during the first
    --  pass of overload resolution, because otherwise a procedure call with
-   --  overloaded actuals may fail to resolve. See 4327-001 for an example.
+   --  overloaded actuals may fail to resolve.
 
    procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id);
    --  Analyze a call of the form "+"(x, y), etc. The prefix of the call
@@ -268,6 +268,11 @@ package body Sem_Ch4 is
    function Try_Object_Operation (N : Node_Id) return Boolean;
    --  Ada 2005 (AI-252): Support the object.operation notation
 
+   procedure wpo (T : Entity_Id);
+   pragma Warnings (Off, wpo);
+   --  Used for debugging: obtain list of primitive operations even if
+   --  type is not frozen and dispatch table is not built yet.
+
    ------------------------
    -- Ambiguous_Operands --
    ------------------------
@@ -366,7 +371,6 @@ package body Sem_Ch4 is
       if Nkind (E) = N_Qualified_Expression then
          Acc_Type := Create_Itype (E_Allocator_Type, N);
          Set_Etype (Acc_Type, Acc_Type);
-         Init_Size_Align (Acc_Type);
          Find_Type (Subtype_Mark (E));
 
          --  Analyze the qualified expression, and apply the name resolution
@@ -491,7 +495,6 @@ package body Sem_Ch4 is
             Type_Id := Process_Subtype (E, N);
             Acc_Type := Create_Itype (E_Allocator_Type, N);
             Set_Etype                    (Acc_Type, Acc_Type);
-            Init_Size_Align              (Acc_Type);
             Set_Directly_Designated_Type (Acc_Type, Type_Id);
             Check_Fully_Declared (Type_Id, N);
 
@@ -971,26 +974,6 @@ package body Sem_Ch4 is
 
          End_Interp_List;
       end if;
-
-      --  Check for not-yet-implemented cases of AI-318. We only need to check
-      --  for inherently limited types, because other limited types will be
-      --  returned by copy, which works just fine.
-      --  If the context is an attribute reference 'Class, this is really a
-      --  type conversion, which is illegal, and will be caught elsewhere.
-
-      if Ada_Version >= Ada_05
-        and then not Debug_Flag_Dot_L
-        and then Is_Inherently_Limited_Type (Etype (N))
-        and then (Nkind_In (Parent (N), N_Selected_Component,
-                                        N_Indexed_Component,
-                                        N_Slice)
-                   or else
-                    (Nkind (Parent (N)) = N_Attribute_Reference
-                       and then Attribute_Name (Parent (N)) /= Name_Class))
-      then
-         Error_Msg_N ("(Ada 2005) limited function call in this context" &
-                      " is not yet implemented", N);
-      end if;
    end Analyze_Call;
 
    ---------------------------
@@ -1444,7 +1427,6 @@ package body Sem_Ch4 is
          --  where the prefix might include functions that return access to
          --  subprograms and others that return a regular type. Disambiguation
          --  of those has to take place in Resolve.
-         --  See e.g. 7117-014 and E317-001.
 
          New_N :=
            Make_Function_Call (Loc,
@@ -2716,7 +2698,10 @@ package body Sem_Ch4 is
 
       procedure Check_Common_Type (T1, T2 : Entity_Id) is
       begin
-         if Covers (T1, T2) or else Covers (T2, T1) then
+         if Covers (T1 => T1, T2 => T2)
+              or else
+            Covers (T1 => T2, T2 => T1)
+         then
             if T1 = Universal_Integer
               or else T1 = Universal_Real
               or else T1 = Any_Character
@@ -2808,12 +2793,50 @@ package body Sem_Ch4 is
 
    procedure Analyze_Reference (N : Node_Id) is
       P        : constant Node_Id := Prefix (N);
+      E        : Entity_Id;
+      T        : Entity_Id;
       Acc_Type : Entity_Id;
+
    begin
       Analyze (P);
+
+      --  An interesting error check, if we take the 'Reference of an object
+      --  for which a pragma Atomic or Volatile has been given, and the type
+      --  of the object is not Atomic or Volatile, then we are in trouble. The
+      --  problem is that no trace of the atomic/volatile status will remain
+      --  for the backend to respect when it deals with the resulting pointer,
+      --  since the pointer type will not be marked atomic (it is a pointer to
+      --  the base type of the object).
+
+      --  It is not clear if that can ever occur, but in case it does, we will
+      --  generate an error message. Not clear if this message can ever be
+      --  generated, and pretty clear that it represents a bug if it is, still
+      --  seems worth checking!
+
+      T := Etype (P);
+
+      if Is_Entity_Name (P)
+        and then Is_Object_Reference (P)
+      then
+         E := Entity (P);
+         T := Etype (P);
+
+         if (Has_Atomic_Components   (E)
+               and then not Has_Atomic_Components   (T))
+           or else
+            (Has_Volatile_Components (E)
+               and then not Has_Volatile_Components (T))
+           or else (Is_Atomic   (E) and then not Is_Atomic   (T))
+           or else (Is_Volatile (E) and then not Is_Volatile (T))
+         then
+            Error_Msg_N ("cannot take reference to Atomic/Volatile object", N);
+         end if;
+      end if;
+
+      --  Carry on with normal processing
+
       Acc_Type := Create_Itype (E_Allocator_Type, N);
-      Set_Etype                    (Acc_Type,  Acc_Type);
-      Init_Size_Align              (Acc_Type);
+      Set_Etype (Acc_Type,  Acc_Type);
       Set_Directly_Designated_Type (Acc_Type, Etype (P));
       Set_Etype (N, Acc_Type);
    end Analyze_Reference;
@@ -2845,7 +2868,8 @@ package body Sem_Ch4 is
       --  It is known that the parent of N denotes a subprogram call. Comp
       --  is an overloadable component of the concurrent type of the prefix.
       --  Determine whether all formals of the parent of N and Comp are mode
-      --  conformant.
+      --  conformant. If the parent node is not analyzed yet it may be an
+      --  indexed component rather than a function call.
 
       ------------------------------
       -- Has_Mode_Conformant_Spec --
@@ -2858,7 +2882,13 @@ package body Sem_Ch4 is
 
       begin
          Comp_Param := First_Formal (Comp);
-         Param := First (Parameter_Associations (Parent (N)));
+
+         if Nkind (Parent (N)) = N_Indexed_Component then
+            Param := First (Expressions (Parent (N)));
+         else
+            Param := First (Parameter_Associations (Parent (N)));
+         end if;
+
          while Present (Comp_Param)
            and then Present (Param)
          loop
@@ -2908,14 +2938,19 @@ package body Sem_Ch4 is
          --  A RACW object can never be used as prefix of a selected
          --  component since that means it is dereferenced without
          --  being a controlling operand of a dispatching operation
-         --  (RM E.2.2(15)).
+         --  (RM E.2.2(16/1)). Before reporting an error, we must check
+         --  whether this is actually a dispatching call in prefix form.
 
          if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type)
            and then Comes_From_Source (N)
          then
-            Error_Msg_N
-              ("invalid dereference of a remote access to class-wide value",
-               N);
+            if Try_Object_Operation (N) then
+               return;
+            else
+               Error_Msg_N
+                 ("invalid dereference of a remote access-to-class-wide value",
+                  N);
+            end if;
 
          --  Normal case of selected component applied to access type
 
@@ -2932,6 +2967,27 @@ package body Sem_Ch4 is
 
             Prefix_Type := Process_Implicit_Dereference_Prefix (Pent, Name);
          end if;
+
+      --  If we have an explicit dereference of a remote access-to-class-wide
+      --  value, then issue an error (see RM-E.2.2(16/1)). However we first
+      --  have to check for the case of a prefix that is a controlling operand
+      --  of a prefixed dispatching call, as the dereference is legal in that
+      --  case. Normally this condition is checked in Validate_Remote_Access_
+      --  To_Class_Wide_Type, but we have to defer the checking for selected
+      --  component prefixes because of the prefixed dispatching call case.
+      --  Note that implicit dereferences are checked for this just above.
+
+      elsif Nkind (Name) = N_Explicit_Dereference
+        and then Is_Remote_Access_To_Class_Wide_Type (Etype (Prefix (Name)))
+        and then Comes_From_Source (N)
+      then
+         if Try_Object_Operation (N) then
+            return;
+         else
+            Error_Msg_N
+              ("invalid dereference of a remote access-to-class-wide value",
+               N);
+         end if;
       end if;
 
       --  (Ada 2005): if the prefix is the limited view of a type, and
@@ -3256,7 +3312,8 @@ package body Sem_Ch4 is
                   if Is_Tagged_Type (Prefix_Type)
                     and then
                       Nkind_In (Parent (N), N_Procedure_Call_Statement,
-                                            N_Function_Call)
+                                            N_Function_Call,
+                                            N_Indexed_Component)
                     and then Has_Mode_Conformant_Spec (Comp)
                   then
                      Has_Candidate := True;
@@ -3322,6 +3379,7 @@ package body Sem_Ch4 is
             --  the controlling formal is implicit ???
 
             elsif Nkind (Parent (N)) /= N_Procedure_Call_Statement
+              and then Nkind (Parent (N)) /= N_Indexed_Component
               and then Try_Object_Operation (N)
             then
                return;
@@ -3899,7 +3957,9 @@ package body Sem_Ch4 is
 
          if Is_Numeric_Type (T1)
            and then Is_Numeric_Type (T2)
-           and then (Covers (T1, T2) or else Covers (T2, T1))
+           and then (Covers (T1 => T1, T2 => T2)
+                       or else
+                     Covers (T1 => T2, T2 => T1))
          then
             Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
          end if;
@@ -3938,7 +3998,9 @@ package body Sem_Ch4 is
 
          elsif Is_Numeric_Type (T1)
            and then Is_Numeric_Type (T2)
-           and then (Covers (T1, T2) or else Covers (T2, T1))
+           and then (Covers (T1 => T1, T2 => T2)
+                       or else
+                     Covers (T1 => T2, T2 => T1))
          then
             Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
 
@@ -3983,7 +4045,9 @@ package body Sem_Ch4 is
          --  already set (case of operation constructed by Exp_Fixed).
 
          if Is_Integer_Type (T1)
-           and then (Covers (T1, T2) or else Covers (T2, T1))
+           and then (Covers (T1 => T1, T2 => T2)
+                       or else
+                     Covers (T1 => T2, T2 => T1))
          then
             Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
          end if;
@@ -4414,7 +4478,7 @@ package body Sem_Ch4 is
       if Nkind (L) = N_Aggregate
         and then Nkind (R) /= N_Aggregate
       then
-         Find_Comparison_Types (R, L, Op_Id, N);
+         Find_Comparison_Types (L => R, R => L, Op_Id => Op_Id, N => N);
          return;
       end if;
 
@@ -4632,7 +4696,7 @@ package body Sem_Ch4 is
       if Nkind (L) = N_Aggregate
         and then Nkind (R) /= N_Aggregate
       then
-         Find_Equality_Types (R, L, Op_Id, N);
+         Find_Equality_Types (L => R, R => L, Op_Id => Op_Id, N => N);
          return;
       end if;
 
@@ -5653,8 +5717,8 @@ package body Sem_Ch4 is
         (Call_Node       : Node_Id;
          Node_To_Replace : Node_Id)
       is
-         Formal_Type  : constant Entity_Id :=
-                          Etype (First_Formal (Entity (Subprog)));
+         Control      : constant Entity_Id := First_Formal (Entity (Subprog));
+         Formal_Type  : constant Entity_Id := Etype (Control);
          First_Actual : Node_Id;
 
       begin
@@ -5716,6 +5780,19 @@ package body Sem_Ch4 is
          elsif Is_Access_Type (Formal_Type)
            and then not Is_Access_Type (Etype (Obj))
          then
+            --  A special case: A.all'access is illegal if A is an access to a
+            --  constant and the context requires an access to a variable.
+
+            if not Is_Access_Constant (Formal_Type) then
+               if (Nkind (Obj) = N_Explicit_Dereference
+                    and then Is_Access_Constant (Etype (Prefix (Obj))))
+                 or else not Is_Variable (Obj)
+               then
+                  Error_Msg_NE
+                    ("actual for& must be a variable", Obj, Control);
+               end if;
+            end if;
+
             Rewrite (First_Actual,
               Make_Attribute_Reference (Loc,
                 Attribute_Name => Name_Access,
@@ -6288,10 +6365,10 @@ package body Sem_Ch4 is
          --  must be identical, and the kind of call indicates the expected
          --  kind of operation (function or procedure). If the type is a
          --  (tagged) synchronized type, the primitive ops are attached to the
-         --  corresponding record type.
+         --  corresponding record (base) type.
 
          if Is_Concurrent_Type (Obj_Type) then
-            Corr_Type := Corresponding_Record_Type (Obj_Type);
+            Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
             Elmt := First_Elmt (Primitive_Operations (Corr_Type));
 
          elsif not Is_Generic_Type (Obj_Type) then
@@ -6480,4 +6557,30 @@ package body Sem_Ch4 is
       end if;
    end Try_Object_Operation;
 
+   ---------
+   -- wpo --
+   ---------
+
+   procedure wpo (T : Entity_Id) is
+      Op : Entity_Id;
+      E  : Elmt_Id;
+
+   begin
+      if not Is_Tagged_Type (T) then
+         return;
+      end if;
+
+      E := First_Elmt (Primitive_Operations (Base_Type (T)));
+      while Present (E) loop
+         Op := Node (E);
+         Write_Int (Int (Op));
+         Write_Str (" === ");
+         Write_Name (Chars (Op));
+         Write_Str (" in ");
+         Write_Name (Chars (Scope (Op)));
+         Next_Elmt (E);
+         Write_Eol;
+      end loop;
+   end wpo;
+
 end Sem_Ch4;