2014-07-18 Hristian Kirtchev <kirtchev@adacore.com>

	* einfo.adb Last_Aggregate_Assignment is now Node 30.
	(Last_Aggregate_Assignment): Include
	constants in the assertion. Update the underlying node.
	(Set_Last_Aggregate_Assignment): Include constants in the
	assertion. Update the underlying node.	(Write_Field11_Name):
	Remove the entry for Last_Aggregate_Assignment.
	(Write_Field30_Name): Add an entry for Last_Aggregate_Assignment.
	* einfo.ads Update the node designation and usage of attribute
	Last_Aggregate_Assignment.
	* exp_aggr.adb (Expand_Array_Aggregate): Store the last
	assignment statement used to initialize a controlled object.
	(Late_Expansion): Store the last assignment statement used to
	initialize a controlled record or an array of controlled objects.
	* exp_ch3.adb (Expand_N_Object_Declaration): Default
	initialization of objects is now performed in a separate routine.
	(Default_Initialize_Object): New routine.
	* exp_ch7.adb (Build_BIP_Cleanup_Stmts): Add formal parameter
	Obj_Id. Update the comment on usage.
	(Find_Last_Init): Remove formal parameter Typ. Update comment on usage.
	Reimplement the logic.	(Find_Last_Init_In_Block): New routine.
	(Is_Init_Call): Add formal parameter Init_Typ. Update the
	comment on usage.  Account for the type init proc when trying
	to determine whether a statement is an initialization call.
	(Make_Adjust_Call): Rename formal parameter For_Parent to
	Skip_Self. Update all occurrences of For_Parent. Account for
	non-tagged types. Update the call to Make_Call.
	(Make_Call): Rename formal parameter For_Parent to Skip_Self. Update
	comment on usage. Update all occurrences of For_Parent.
	(Make_Final_Call): Rename formal parameter For_Parent to
	Skip_Self. Update all occurrences of For_Parent. Account
	for non-tagged types. Update the call to Make_Call.
	(Process_Object_Declaration): Most variables and constants are
	now local to the routine.
	* exp_ch7.ads (Make_Adjust_Call): Rename formal parameter
	For_Parent to Skip_Self. Update the comment on usage.
	(Make_Final_Call): Rename formal parameter For_Parent to
	Skip_Self. Update the comment on usage.

2014-07-18  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch9.adb (Analyze_Requeue): The entry being referenced
	can be a procedure that is implemented by entry, and have a
	formal that is a synchronized interface.  It does not have to
	be declared as a protected operation.



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

8 files changed, 642 insertions, 378 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 49cbaecbe77..ac04798710c 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,50 @@
+2014-07-18  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* einfo.adb Last_Aggregate_Assignment is now Node 30.
+	(Last_Aggregate_Assignment): Include
+	constants in the assertion. Update the underlying node.
+	(Set_Last_Aggregate_Assignment): Include constants in the
+	assertion. Update the underlying node.	(Write_Field11_Name):
+	Remove the entry for Last_Aggregate_Assignment.
+	(Write_Field30_Name): Add an entry for Last_Aggregate_Assignment.
+	* einfo.ads Update the node designation and usage of attribute
+	Last_Aggregate_Assignment.
+	* exp_aggr.adb (Expand_Array_Aggregate): Store the last
+	assignment statement used to initialize a controlled object.
+	(Late_Expansion): Store the last assignment statement used to
+	initialize a controlled record or an array of controlled objects.
+	* exp_ch3.adb (Expand_N_Object_Declaration): Default
+	initialization of objects is now performed in a separate routine.
+	(Default_Initialize_Object): New routine.
+	* exp_ch7.adb (Build_BIP_Cleanup_Stmts): Add formal parameter
+	Obj_Id. Update the comment on usage.
+	(Find_Last_Init): Remove formal parameter Typ. Update comment on usage.
+	Reimplement the logic.	(Find_Last_Init_In_Block): New routine.
+	(Is_Init_Call): Add formal parameter Init_Typ. Update the
+	comment on usage.  Account for the type init proc when trying
+	to determine whether a statement is an initialization call.
+	(Make_Adjust_Call): Rename formal parameter For_Parent to
+	Skip_Self. Update all occurrences of For_Parent. Account for
+	non-tagged types. Update the call to Make_Call.
+	(Make_Call): Rename formal parameter For_Parent to Skip_Self. Update
+	comment on usage. Update all occurrences of For_Parent.
+	(Make_Final_Call): Rename formal parameter For_Parent to
+	Skip_Self. Update all occurrences of For_Parent. Account
+	for non-tagged types. Update the call to Make_Call.
+	(Process_Object_Declaration): Most variables and constants are
+	now local to the routine.
+	* exp_ch7.ads (Make_Adjust_Call): Rename formal parameter
+	For_Parent to Skip_Self. Update the comment on usage.
+	(Make_Final_Call): Rename formal parameter For_Parent to
+	Skip_Self. Update the comment on usage.
+
+2014-07-18  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch9.adb (Analyze_Requeue): The entry being referenced
+	can be a procedure that is implemented by entry, and have a
+	formal that is a synchronized interface.  It does not have to
+	be declared as a protected operation.
+
 2014-07-18  Robert Dewar  <dewar@adacore.com>
 
 	* gnat_rm.texi: Remove mention of obsolete attributes
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index dbefc1ad773..634d92acaea 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -101,7 +101,6 @@ package body Einfo is
    --    Entry_Component                 Node11
    --    Enumeration_Pos                 Uint11
    --    Generic_Homonym                 Node11
-   --    Last_Aggregate_Assignment       Node11
    --    Protected_Body_Subprogram       Node11
    --    Block_Node                      Node11
 
@@ -246,6 +245,7 @@ package body Einfo is
    --    Subprograms_For_Type            Node29
 
    --    Corresponding_Equality          Node30
+   --    Last_Aggregate_Assignment       Node30
    --    Static_Initialization           Node30
 
    --    Thunk_Entity                    Node31
@@ -2433,8 +2433,8 @@ package body Einfo is
 
    function Last_Aggregate_Assignment (Id : E) return N is
    begin
-      pragma Assert (Ekind (Id) = E_Variable);
-      return Node11 (Id);
+      pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
+      return Node30 (Id);
    end Last_Aggregate_Assignment;
 
    function Last_Assignment (Id : E) return N is
@@ -5195,8 +5195,8 @@ package body Einfo is
 
    procedure Set_Last_Aggregate_Assignment (Id : E; V : N) is
    begin
-      pragma Assert (Ekind (Id) = E_Variable);
-      Set_Node11 (Id, V);
+      pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
+      Set_Node30 (Id, V);
    end Set_Last_Aggregate_Assignment;
 
    procedure Set_Last_Assignment (Id : E; V : N) is
@@ -8727,9 +8727,6 @@ package body Einfo is
          when E_Generic_Package                            =>
             Write_Str ("Generic_Homonym");
 
-         when E_Variable                                   =>
-            Write_Str ("Last_Aggregate_Assignment");
-
          when E_Function                                   |
               E_Procedure                                  |
               E_Entry                                      |
@@ -9526,6 +9523,10 @@ package body Einfo is
          when E_Function                                   =>
             Write_Str ("Corresponding_Equality");
 
+         when E_Constant                                   |
+              E_Variable                                   =>
+            Write_Str ("Last_Aggregate_Assignment");
+
          when E_Procedure                                  =>
             Write_Str ("Static_Initialization");
 
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index fb55d1b3463..3422ac0455c 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -3068,11 +3068,11 @@ package Einfo is
 --       initialization, it may or may not be set if the type does have
 --       preelaborable initialization.
 
---    Last_Aggregate_Assignment (Node11)
---       Applies to controlled variables initialized by an aggregate. Points to
---       the last statement associated with the expansion of the aggregate. The
---       attribute is used by the finalization machinery when marking an object
---       as successfully initialized.
+--    Last_Aggregate_Assignment (Node30)
+--       Applies to controlled constants and variables initialized by an
+--       aggregate. Points to the last statement associated with the expansion
+--       of the aggregate. The attribute is used by the finalization machinery
+--       when marking an object as successfully initialized.
 
 --    Last_Assignment (Node26)
 --       Defined in entities for variables, and OUT or IN OUT formals. Set for
@@ -5412,6 +5412,7 @@ package Einfo is
    --    Related_Type                        (Node27)   (constants only)
    --    Initialization_Statements           (Node28)
    --    BIP_Initialization_Call             (Node29)
+   --    Last_Aggregate_Assignment           (Node30)
    --    Linker_Section_Pragma               (Node33)
    --    Has_Alignment_Clause                (Flag46)
    --    Has_Atomic_Components               (Flag86)
@@ -6102,7 +6103,6 @@ package Einfo is
    --    Hiding_Loop_Variable                (Node8)
    --    Current_Value                       (Node9)
    --    Encapsulating_State                 (Node10)
-   --    Last_Aggregate_Assignment           (Node11)
    --    Esize                               (Uint12)
    --    Extra_Accessibility                 (Node13)
    --    Alignment                           (Uint14)
@@ -6121,6 +6121,7 @@ package Einfo is
    --    Related_Type                        (Node27)
    --    Initialization_Statements           (Node28)
    --    BIP_Initialization_Call             (Node29)
+   --    Last_Aggregate_Assignment           (Node30)
    --    Linker_Section_Pragma               (Node33)
    --    Contract                            (Node34)
    --    Has_Alignment_Clause                (Flag46)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 3c2101f218b..de784b2daf9 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -75,6 +75,15 @@ package body Exp_Aggr is
    type Case_Table_Type is array (Nat range <>) of Case_Bounds;
    --  Table type used by Check_Case_Choices procedure
 
+   procedure Collect_Initialization_Statements
+     (Obj        : Entity_Id;
+      N          : Node_Id;
+      Node_After : Node_Id);
+   --  If Obj is not frozen, collect actions inserted after N until, but not
+   --  including, Node_After, for initialization of Obj, and move them to an
+   --  expression with actions, which becomes the Initialization_Statements for
+   --  Obj.
+
    function Has_Default_Init_Comps (N : Node_Id) return Boolean;
    --  N is an aggregate (record or array). Checks the presence of default
    --  initialization (<>) in any component (Ada 2005: AI-287).
@@ -103,15 +112,6 @@ package body Exp_Aggr is
    --  statement of variant part will usually be small and probably in near
    --  sorted order.
 
-   procedure Collect_Initialization_Statements
-     (Obj        : Entity_Id;
-      N          : Node_Id;
-      Node_After : Node_Id);
-   --  If Obj is not frozen, collect actions inserted after N until, but not
-   --  including, Node_After, for initialization of Obj, and move them to an
-   --  expression with actions, which becomes the Initialization_Statements for
-   --  Obj.
-
    ------------------------------------------------------
    -- Local subprograms for Record Aggregate Expansion --
    ------------------------------------------------------
@@ -5233,6 +5233,19 @@ package body Exp_Aggr is
              Index       => First_Index (Typ),
              Into        => Target,
              Scalar_Comp => Is_Scalar_Type (Ctyp));
+
+         --  Save the last assignment statement associated with the aggregate
+         --  when building a controlled object. This reference is utilized by
+         --  the finalization machinery when marking an object as successfully
+         --  initialized.
+
+         if Needs_Finalization (Typ)
+           and then Is_Entity_Name (Target)
+           and then Present (Entity (Target))
+           and then Ekind_In (Entity (Target), E_Constant, E_Variable)
+         then
+            Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code));
+         end if;
       end;
 
       --  If the aggregate is the expression in a declaration, the expanded
@@ -6210,23 +6223,8 @@ package body Exp_Aggr is
       if Is_Record_Type (Etype (N)) then
          Aggr_Code := Build_Record_Aggr_Code (N, Typ, Target);
 
-         --  Save the last assignment statement associated with the aggregate
-         --  when building a controlled object. This reference is utilized by
-         --  the finalization machinery when marking an object as successfully
-         --  initialized.
-
-         if Needs_Finalization (Typ)
-           and then Is_Entity_Name (Target)
-           and then Present (Entity (Target))
-           and then Ekind (Entity (Target)) = E_Variable
-         then
-            Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code));
-         end if;
-
-         return Aggr_Code;
-
       else pragma Assert (Is_Array_Type (Etype (N)));
-         return
+         Aggr_Code :=
            Build_Array_Aggr_Code
              (N           => N,
               Ctype       => Component_Type (Etype (N)),
@@ -6235,6 +6233,21 @@ package body Exp_Aggr is
               Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)),
               Indexes     => No_List);
       end if;
+
+      --  Save the last assignment statement associated with the aggregate
+      --  when building a controlled object. This reference is utilized by
+      --  the finalization machinery when marking an object as successfully
+      --  initialized.
+
+      if Needs_Finalization (Typ)
+        and then Is_Entity_Name (Target)
+        and then Present (Entity (Target))
+        and then Ekind_In (Entity (Target), E_Constant, E_Variable)
+      then
+         Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code));
+      end if;
+
+      return Aggr_Code;
    end Late_Expansion;
 
    ----------------------------------
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index b24a20439c3..160cfea761f 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -2623,9 +2623,8 @@ package body Exp_Ch3 is
 
                    Statements => New_List (
                      Make_Procedure_Call_Statement (Loc,
-                       Name =>
+                       Name                   =>
                          New_Occurrence_Of (Local_DF_Id, Loc),
-
                        Parameter_Associations => New_List (
                          Make_Identifier (Loc, Name_uInit),
                          New_Occurrence_Of (Standard_False, Loc))),
@@ -4857,20 +4856,16 @@ package body Exp_Ch3 is
       Typ      : constant Entity_Id  := Etype (Def_Id);
       Base_Typ : constant Entity_Id  := Base_Type (Typ);
       Expr_Q   : Node_Id;
-      Id_Ref   : Node_Id;
-      New_Ref  : Node_Id;
-
-      Init_After : Node_Id := N;
-      --  Node after which the init proc call is to be inserted. This is
-      --  normally N, except for the case of a shared passive variable, in
-      --  which case the init proc call must be inserted only after the bodies
-      --  of the shared variable procedures have been seen.
 
       function Build_Equivalent_Aggregate return Boolean;
       --  If the object has a constrained discriminated type and no initial
       --  value, it may be possible to build an equivalent aggregate instead,
       --  and prevent an actual call to the initialization procedure.
 
+      procedure Default_Initialize_Object (After : Node_Id);
+      --  Generate all default initialization actions for object Def_Id. Any
+      --  new code is inserted after node After.
+
       function Rewrite_As_Renaming return Boolean;
       --  Indicate whether to rewrite a declaration with initialization into an
       --  object renaming declaration (see below).
@@ -4911,11 +4906,10 @@ package body Exp_Ch3 is
          end if;
 
          if Ekind (Current_Scope) = E_Package
-          and then
-            (Restriction_Active (No_Elaboration_Code)
-              or else Is_Preelaborated (Current_Scope))
+           and then
+             (Restriction_Active (No_Elaboration_Code)
+               or else Is_Preelaborated (Current_Scope))
          then
-
             --  Building a static aggregate is possible if the discriminants
             --  have static values and the other components have static
             --  defaults or none.
@@ -5005,6 +4999,263 @@ package body Exp_Ch3 is
          end if;
       end Build_Equivalent_Aggregate;
 
+      -------------------------------
+      -- Default_Initialize_Object --
+      -------------------------------
+
+      procedure Default_Initialize_Object (After : Node_Id) is
+         function New_Object_Reference return Node_Id;
+         --  Return a new reference to Def_Id with attributes Assignment_OK and
+         --  Must_Not_Freeze already set.
+
+         --------------------------
+         -- New_Object_Reference --
+         --------------------------
+
+         function New_Object_Reference return Node_Id is
+            Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc);
+
+         begin
+            --  The call to the type init proc or [Deep_]Finalize must not
+            --  freeze the related object as the call is internally generated.
+            --  This way legal rep clauses that apply to the object will not be
+            --  flagged. Note that the initialization call may be removed if
+            --  pragma Import is encountered or moved to the freeze actions of
+            --  the object because of an address clause.
+
+            Set_Assignment_OK   (Obj_Ref);
+            Set_Must_Not_Freeze (Obj_Ref);
+
+            return Obj_Ref;
+         end New_Object_Reference;
+
+         --  Local variables
+
+         Abrt_HSS   : Node_Id;
+         Abrt_Id    : Entity_Id;
+         Abrt_Stmts : List_Id;
+         Aggr_Init  : Node_Id;
+         Comp_Init  : List_Id := No_List;
+         Fin_Call   : Node_Id;
+         Fin_Stmts  : List_Id := No_List;
+         Obj_Init   : Node_Id := Empty;
+         Obj_Ref    : Node_Id;
+
+      --  Start of processing for Default_Initialize_Object
+
+      begin
+         --  Step 1: Initialize the object
+
+         if Needs_Finalization (Typ) and then not No_Initialization (N) then
+            Obj_Init :=
+              Make_Init_Call
+                (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
+                 Typ     => Typ);
+         end if;
+
+         --  Step 2: Initialize the components of the object
+
+         --  Do not initialize the components if their initialization is
+         --  prohibited or the type represents a value type in a .NET VM.
+
+         if Has_Non_Null_Base_Init_Proc (Typ)
+           and then not No_Initialization (N)
+           and then not Initialization_Suppressed (Typ)
+           and then not Is_Value_Type (Typ)
+         then
+            --  Do not initialize the components if No_Default_Initialization
+            --  applies as the the actual restriction check will occur later
+            --  when the object is frozen as it is not known yet whether the
+            --  object is imported or not.
+
+            if not Restriction_Active (No_Default_Initialization) then
+
+               --  If the values of the components are compile-time known, use
+               --  their prebuilt aggregate form directly.
+
+               Aggr_Init := Static_Initialization (Base_Init_Proc (Typ));
+
+               if Present (Aggr_Init) then
+                  Set_Expression
+                    (N, New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope));
+
+               --  If type has discriminants, try to build an equivalent
+               --  aggregate using discriminant values from the declaration.
+               --  This is a useful optimization, in particular if restriction
+               --  No_Elaboration_Code is active.
+
+               elsif Build_Equivalent_Aggregate then
+                  null;
+
+               --  Otherwise invoke the type init proc
+
+               else
+                  Obj_Ref := New_Object_Reference;
+
+                  if Comes_From_Source (Def_Id) then
+                     Initialization_Warning (Obj_Ref);
+                  end if;
+
+                  Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ);
+               end if;
+            end if;
+
+         --  Provide a default value if the object needs simple initialization
+         --  and does not already have an initial value. A generated temporary
+         --  do not require initialization because it will be assigned later.
+
+         elsif Needs_Simple_Initialization
+                 (Typ, Initialize_Scalars
+                         and then not Has_Following_Address_Clause (N))
+           and then not Is_Internal (Def_Id)
+           and then not Has_Init_Expression (N)
+         then
+            Set_No_Initialization (N, False);
+            Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id)));
+            Analyze_And_Resolve (Expression (N), Typ);
+         end if;
+
+         --  Step 3: Add partial finalization and abort actions, generate:
+
+         --    Type_Init_Proc (Obj);
+         --    begin
+         --       Deep_Initialize (Obj);
+         --    exception
+         --       when others =>
+         --          Deep_Finalize (Obj, Self => False);
+         --          raise;
+         --    end;
+
+         --  Step 3a: Build the finalization block (if applicable)
+
+         --  The finalization block is required when both the object and its
+         --  controlled components are to be initialized. The block finalizes
+         --  the components if the object initialization fails.
+
+         if Has_Controlled_Component (Typ)
+           and then Present (Comp_Init)
+           and then Present (Obj_Init)
+           and then not Restriction_Active (No_Exception_Propagation)
+         then
+            --  Generate:
+            --    Type_Init_Proc (Obj);
+
+            Fin_Stmts := Comp_Init;
+
+            --  Generate:
+            --    begin
+            --       Deep_Initialize (Obj);
+            --    exception
+            --       when others =>
+            --          Deep_Finalize (Obj, Self => False);
+            --          raise;
+            --    end;
+
+            Fin_Call :=
+              Make_Final_Call
+                (Obj_Ref   => New_Object_Reference,
+                 Typ       => Typ,
+                 Skip_Self => True);
+
+            if Present (Fin_Call) then
+
+               --  Do not emit warnings related to the elaboration order when a
+               --  controlled object is declared before the body of Finalize is
+               --  seen.
+
+               Set_No_Elaboration_Check (Fin_Call);
+
+               Append_To (Fin_Stmts,
+                 Make_Block_Statement (Loc,
+                   Declarations               => No_List,
+
+                   Handled_Statement_Sequence =>
+                     Make_Handled_Sequence_Of_Statements (Loc,
+                       Statements         => New_List (Obj_Init),
+
+                       Exception_Handlers => New_List (
+                         Make_Exception_Handler (Loc,
+                           Exception_Choices => New_List (
+                             Make_Others_Choice (Loc)),
+
+                           Statements        => New_List (
+                             Fin_Call,
+                             Make_Raise_Statement (Loc)))))));
+            end if;
+
+         --  Finalization is not required, the initialization calls are passed
+         --  to the abort block building circuitry, generate:
+
+         --    Type_Init_Proc (Obj);
+         --    Deep_Initialize (Obj);
+
+         else
+            if Present (Comp_Init) then
+               Fin_Stmts := Comp_Init;
+            end if;
+
+            if Present (Obj_Init) then
+               if No (Fin_Stmts) then
+                  Fin_Stmts := New_List;
+               end if;
+
+               Append_To (Fin_Stmts, Obj_Init);
+            end if;
+         end if;
+
+         --  Step 3b: Build the abort block (if applicable)
+
+         --  The abort block is required when aborts are allowed and there is
+         --  at least one initialization call that needs protection.
+
+         if Abort_Allowed
+           and then Present (Comp_Init)
+           and then Present (Obj_Init)
+         then
+            --  Generate:
+            --    Abort_Defer;
+
+            Prepend_To (Fin_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
+
+            --  Generate:
+            --    begin
+            --       Abort_Defer;
+            --       <finalization statements>
+            --    at end
+            --       Abort_Undefer_Direct;
+            --    end;
+
+            Abrt_Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
+            Set_Etype (Abrt_Id, Standard_Void_Type);
+            Set_Scope (Abrt_Id, Current_Scope);
+
+            Abrt_HSS :=
+              Make_Handled_Sequence_Of_Statements (Loc,
+                Statements  => Fin_Stmts,
+                At_End_Proc =>
+                  New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc));
+
+            Abrt_Stmts := New_List (
+              Make_Block_Statement (Loc,
+                Identifier                 => New_Occurrence_Of (Abrt_Id, Loc),
+                Declarations               => No_List,
+                Handled_Statement_Sequence => Abrt_HSS));
+
+            Expand_At_End_Handler (Abrt_HSS, Abrt_Id);
+
+         --  Abort is not required, the construct from Step 3a is to be added
+         --  in the tree (either finalization block or single initialization
+         --  call).
+
+         else
+            Abrt_Stmts := Fin_Stmts;
+         end if;
+
+         --  Step 4: Insert the whole initialization sequence into the tree
+
+         Insert_Actions_After (After, Abrt_Stmts);
+      end Default_Initialize_Object;
+
       -------------------------
       -- Rewrite_As_Renaming --
       -------------------------
@@ -5018,6 +5269,17 @@ package body Exp_Ch3 is
            and then Is_Entity_Name (Obj_Def);
       end Rewrite_As_Renaming;
 
+      --  Local variables
+
+      Id_Ref  : Node_Id;
+      New_Ref : Node_Id;
+
+      Init_After : Node_Id := N;
+      --  Node after which the initialization actions are to be inserted. This
+      --  is normally N, except for the case of a shared passive variable, in
+      --  which case the init proc call must be inserted only after the bodies
+      --  of the shared variable procedures have been seen.
+
    --  Start of processing for Expand_N_Object_Declaration
 
    begin
@@ -5118,153 +5380,7 @@ package body Exp_Ch3 is
               Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
          end if;
 
-         --  Expand Initialize call for controlled objects. One may wonder why
-         --  the Initialize Call is not done in the regular Init procedure
-         --  attached to the record type. That's because the init procedure is
-         --  recursively called on each component, including _Parent, thus the
-         --  Init call for a controlled object would generate not only one
-         --  Initialize call as it is required but one for each ancestor of
-         --  its type. This processing is suppressed if No_Initialization set.
-
-         if not Needs_Finalization (Typ) or else No_Initialization (N) then
-            null;
-
-         elsif not Abort_Allowed or else not Comes_From_Source (N) then
-            Insert_Action_After (Init_After,
-              Make_Init_Call
-                (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
-                 Typ     => Base_Typ));
-
-         --  Abort allowed
-
-         else
-            --  We need to protect the initialize call
-
-            --  begin
-            --     Defer_Abort.all;
-            --     Initialize (...);
-            --  at end
-            --     Undefer_Abort.all;
-            --  end;
-
-            --  ??? this won't protect the initialize call for controlled
-            --  components which are part of the init proc, so this block
-            --  should probably also contain the call to _init_proc but this
-            --  requires some code reorganization...
-
-            declare
-               L   : constant List_Id := New_List (
-                       Make_Init_Call
-                         (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
-                          Typ     => Base_Typ));
-
-               Blk : constant Node_Id :=
-                       Make_Block_Statement (Loc,
-                         Handled_Statement_Sequence =>
-                           Make_Handled_Sequence_Of_Statements (Loc, L));
-
-            begin
-               Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer));
-               Set_At_End_Proc (Handled_Statement_Sequence (Blk),
-                 New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc));
-               Insert_Actions_After (Init_After, New_List (Blk));
-               Expand_At_End_Handler
-                 (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk)));
-            end;
-         end if;
-
-         --  Call type initialization procedure if there is one. We build the
-         --  call and put it immediately after the object declaration, so that
-         --  it will be expanded in the usual manner. Note that this will
-         --  result in proper handling of defaulted discriminants.
-
-         --  Need call if there is a base init proc
-
-         if Has_Non_Null_Base_Init_Proc (Typ)
-
-           --  Suppress call if No_Initialization set on declaration
-
-           and then not No_Initialization (N)
-
-           --  Suppress call for special case of value type for VM
-
-           and then not Is_Value_Type (Typ)
-
-           --  Suppress call if initialization suppressed for the type
-
-           and then not Initialization_Suppressed (Typ)
-         then
-            --  Return without initializing when No_Default_Initialization
-            --  applies. Note that the actual restriction check occurs later,
-            --  when the object is frozen, because we don't know yet whether
-            --  the object is imported, which is a case where the check does
-            --  not apply.
-
-            if Restriction_Active (No_Default_Initialization) then
-               return;
-            end if;
-
-            --  The call to the initialization procedure does NOT freeze the
-            --  object being initialized. This is because the call is not a
-            --  source level call. This works fine, because the only possible
-            --  statements depending on freeze status that can appear after the
-            --  Init_Proc call are rep clauses which can safely appear after
-            --  actual references to the object. Note that this call may
-            --  subsequently be removed (if a pragma Import is encountered),
-            --  or moved to the freeze actions for the object (e.g. if an
-            --  address clause is applied to the object, causing it to get
-            --  delayed freezing).
-
-            Id_Ref := New_Occurrence_Of (Def_Id, Loc);
-            Set_Must_Not_Freeze (Id_Ref);
-            Set_Assignment_OK (Id_Ref);
-
-            declare
-               Init_Expr : constant Node_Id :=
-                             Static_Initialization (Base_Init_Proc (Typ));
-
-            begin
-               if Present (Init_Expr) then
-                  Set_Expression
-                    (N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope));
-                  return;
-
-               --  If type has discriminants, try to build equivalent aggregate
-               --  using discriminant values from the declaration. This
-               --  is a useful optimization, in particular if restriction
-               --  No_Elaboration_Code is active.
-
-               elsif Build_Equivalent_Aggregate then
-                  return;
-
-               else
-                  Initialization_Warning (Id_Ref);
-
-                  Insert_Actions_After (Init_After,
-                    Build_Initialization_Call (Loc, Id_Ref, Typ));
-               end if;
-            end;
-
-         --  If simple initialization is required, then set an appropriate
-         --  simple initialization expression in place. This special
-         --  initialization is required even though No_Init_Flag is present,
-         --  but is not needed if there was an explicit initialization.
-
-         --  An internally generated temporary needs no initialization because
-         --  it will be assigned subsequently. In particular, there is no point
-         --  in applying Initialize_Scalars to such a temporary.
-
-         elsif Needs_Simple_Initialization
-                 (Typ,
-                  Initialize_Scalars
-                    and then not Has_Following_Address_Clause (N))
-           and then not Is_Internal (Def_Id)
-           and then not Has_Init_Expression (N)
-         then
-            Set_No_Initialization (N, False);
-            Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id)));
-            Analyze_And_Resolve (Expression (N), Typ);
-         end if;
+         Default_Initialize_Object (Init_After);
 
          --  Generate attribute for Persistent_BSS if needed
 
@@ -7971,8 +8087,8 @@ package body Exp_Ch3 is
 
                if Warning_Needed then
                   Error_Msg_N
-                    ("Objects of the type cannot be initialized "
-                     & "statically by default??", Parent (E));
+                    ("Objects of the type cannot be initialized statically "
+                     & "by default??", Parent (E));
                end if;
             end if;
 
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index b98362fc70e..c6bec4b1fa8 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -380,14 +380,14 @@ package body Exp_Ch7 is
    --  Initial_Condition. N denotes the package spec or body.
 
    function Make_Call
-     (Loc        : Source_Ptr;
-      Proc_Id    : Entity_Id;
-      Param      : Node_Id;
-      For_Parent : Boolean := False) return Node_Id;
+     (Loc       : Source_Ptr;
+      Proc_Id   : Entity_Id;
+      Param     : Node_Id;
+      Skip_Self : Boolean := False) return Node_Id;
    --  Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
-   --  routine [Deep_]Adjust / Finalize and an object parameter, create an
-   --  adjust / finalization call. Flag For_Parent should be set when field
-   --  _parent is being processed.
+   --  routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
+   --  an adjust or finalization call. Wnen flag Skip_Self is set, the related
+   --  action has an effect on the components only (if any).
 
    function Make_Deep_Proc
      (Prim  : Final_Primitives;
@@ -2066,22 +2066,13 @@ package body Exp_Ch7 is
          Has_No_Init  : Boolean := False;
          Is_Protected : Boolean := False)
       is
-         Obj_Id    : constant Entity_Id := Defining_Identifier (Decl);
-         Loc       : constant Source_Ptr := Sloc (Decl);
-         Body_Ins  : Node_Id;
-         Count_Ins : Node_Id;
-         Fin_Call  : Node_Id;
-         Fin_Stmts : List_Id;
-         Inc_Decl  : Node_Id;
-         Label     : Node_Id;
-         Label_Id  : Entity_Id;
-         Obj_Ref   : Node_Id;
-         Obj_Typ   : Entity_Id;
+         Loc : constant Source_Ptr := Sloc (Decl);
 
-         function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
-         --  Once it has been established that the current object is in fact a
-         --  return object of build-in-place function Func_Id, generate the
-         --  following cleanup code:
+         function Build_BIP_Cleanup_Stmts
+           (Func_Id : Entity_Id;
+            Obj_Id  : Entity_Id) return Node_Id;
+         --  Func_Id denotes a build-in-place function. Obj_Id is the return
+         --  object of Func_Id. Generate the following cleanup code:
          --
          --    if BIPallocfrom > Secondary_Stack'Pos
          --      and then BIPfinalizationmaster /= null
@@ -2100,21 +2091,20 @@ package body Exp_Ch7 is
 
          procedure Find_Last_Init
            (Decl        : Node_Id;
-            Typ         : Entity_Id;
             Last_Init   : out Node_Id;
             Body_Insert : out Node_Id);
-         --  An object declaration has at least one and at most two init calls:
-         --  that of the type and the user-defined initialize. Given an object
-         --  declaration, Last_Init denotes the last initialization call which
-         --  follows the declaration. Body_Insert denotes the place where the
-         --  finalizer body could be potentially inserted.
+         --  Find the last initialization call related to object declaration
+         --  Decl. Last_Init denotes the last initialization call which follows
+         --  Decl. Body_Insert denotes the finalizer body could be potentially
+         --  inserted.
 
          -----------------------------
          -- Build_BIP_Cleanup_Stmts --
          -----------------------------
 
          function Build_BIP_Cleanup_Stmts
-           (Func_Id : Entity_Id) return Node_Id
+           (Func_Id : Entity_Id;
+            Obj_Id  : Entity_Id) return Node_Id
          is
             Decls      : constant List_Id := New_List;
             Fin_Mas_Id : constant Entity_Id :=
@@ -2255,58 +2245,109 @@ package body Exp_Ch7 is
 
          procedure Find_Last_Init
            (Decl        : Node_Id;
-            Typ         : Entity_Id;
             Last_Init   : out Node_Id;
             Body_Insert : out Node_Id)
          is
+            function Find_Last_Init_In_Block
+              (Blk      : Node_Id;
+               Init_Typ : Entity_Id) return Node_Id;
+            --  Find the last initialization call within the statements of
+            --  block Blk. Init_Typ is type of the object being initialized.
+
             function Is_Init_Call
-              (N   : Node_Id;
-               Typ : Entity_Id) return Boolean;
-            --  Given an arbitrary node, determine whether N is a procedure
-            --  call and if it is, try to match the name of the call with the
-            --  [Deep_]Initialize proc of Typ.
+              (N        : Node_Id;
+               Init_Typ : Entity_Id) return Boolean;
+            --  Determine whether node N denotes one of the initialization
+            --  procedures of type Init_Typ.
 
             function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
             --  Given a statement which is part of a list, return the next
-            --  real statement while skipping over dynamic elab checks.
+            --  statement while skipping over dynamic elab checks.
+
+            -----------------------------
+            -- Find_Last_Init_In_Block --
+            -----------------------------
+
+            function Find_Last_Init_In_Block
+              (Blk      : Node_Id;
+               Init_Typ : Entity_Id) return Node_Id
+            is
+               HSS  : constant Node_Id := Handled_Statement_Sequence (Blk);
+               Stmt : Node_Id;
+
+            begin
+               --  Examine the individual statements of the block in reverse to
+               --  locate the last initialization call.
+
+               if Present (HSS) and then Present (Statements (HSS)) then
+                  Stmt := Last (Statements (HSS));
+                  while Present (Stmt) loop
+
+                     --  Peek inside nested blocks in case aborts are allowed
+
+                     if Nkind (Stmt) = N_Block_Statement then
+                        return Find_Last_Init_In_Block (Stmt, Init_Typ);
+
+                     elsif Is_Init_Call (Stmt, Init_Typ) then
+                        return Stmt;
+                     end if;
+
+                     Prev (Stmt);
+                  end loop;
+               end if;
+
+               return Empty;
+            end Find_Last_Init_In_Block;
 
             ------------------
             -- Is_Init_Call --
             ------------------
 
             function Is_Init_Call
-              (N   : Node_Id;
-               Typ : Entity_Id) return Boolean
+              (N        : Node_Id;
+               Init_Typ : Entity_Id) return Boolean
             is
-            begin
-               --  A call to [Deep_]Initialize is always direct
+               Call_Id   : Entity_Id;
+               Deep_Init : Entity_Id := Empty;
+               Prim_Init : Entity_Id := Empty;
+               Type_Init : Entity_Id := Empty;
 
+            begin
                if Nkind (N) = N_Procedure_Call_Statement
                  and then Nkind (Name (N)) = N_Identifier
                then
-                  declare
-                     Call_Ent  : constant Entity_Id := Entity (Name (N));
-                     Deep_Init : constant Entity_Id :=
-                                   TSS (Typ, TSS_Deep_Initialize);
-                     Init      : Entity_Id := Empty;
+                  Call_Id := Entity (Name (N));
 
-                  begin
-                     --  A type may have controlled components but not be
-                     --  controlled.
+                  --  Obtain all possible initialization routines of the object
+                  --  type and try to match the procedure call against one of
+                  --  them.
+
+                  --  Deep_Initialize
+
+                  Deep_Init := TSS (Init_Typ, TSS_Deep_Initialize);
+
+                  --  Primitive Initialize
 
-                     if Is_Controlled (Typ) then
-                        Init := Find_Prim_Op (Typ, Name_Initialize);
+                  if Is_Controlled (Init_Typ) then
+                     Prim_Init := Find_Prim_Op (Init_Typ, Name_Initialize);
 
-                        if Present (Init) then
-                           Init := Ultimate_Alias (Init);
-                        end if;
+                     if Present (Prim_Init) then
+                        Prim_Init := Ultimate_Alias (Prim_Init);
                      end if;
+                  end if;
 
-                     return
-                       (Present (Deep_Init) and then Call_Ent = Deep_Init)
-                         or else
-                       (Present (Init)      and then Call_Ent = Init);
-                  end;
+                  --  Type initialization routine
+
+                  if Has_Non_Null_Base_Init_Proc (Init_Typ) then
+                     Type_Init := Base_Init_Proc (Init_Typ);
+                  end if;
+
+                  return
+                    (Present (Deep_Init) and then Call_Id = Deep_Init)
+                      or else
+                    (Present (Prim_Init) and then Call_Id = Prim_Init)
+                      or else
+                    (Present (Type_Init) and then Call_Id = Type_Init);
                end if;
 
                return False;
@@ -2333,11 +2374,13 @@ package body Exp_Ch7 is
 
             --  Local variables
 
-            Obj_Id : constant Entity_Id := Defining_Entity (Decl);
-            Nod_1  : Node_Id := Empty;
-            Nod_2  : Node_Id := Empty;
-            Stmt   : Node_Id;
-            Utyp   : Entity_Id;
+            Obj_Id   : constant Entity_Id := Defining_Entity (Decl);
+            Obj_Typ  : constant Entity_Id := Base_Type (Etype (Obj_Id));
+            Call     : Node_Id;
+            Init_Typ : Entity_Id := Obj_Typ;
+            Is_Conc  : Boolean   := False;
+            Stmt     : Node_Id;
+            Stmt_2   : Node_Id;
 
          --  Start of processing for Find_Last_Init
 
@@ -2346,24 +2389,42 @@ package body Exp_Ch7 is
             Body_Insert := Empty;
 
             --  Object renamings and objects associated with controlled
-            --  function results do not have initialization calls.
+            --  function results do not require initialization.
 
             if Has_No_Init then
                return;
             end if;
 
-            if Is_Concurrent_Type (Typ) then
-               Utyp := Corresponding_Record_Type (Typ);
-            else
-               Utyp := Typ;
-            end if;
+            --  Obtain the proper type of the object being initialized
 
-            if Is_Private_Type (Utyp)
-              and then Present (Full_View (Utyp))
-            then
-               Utyp := Full_View (Utyp);
+            loop
+               if Is_Concurrent_Type (Init_Typ)
+                 and then Present (Corresponding_Record_Type (Init_Typ))
+               then
+                  Is_Conc  := True;
+                  Init_Typ := Corresponding_Record_Type (Init_Typ);
+
+               elsif Is_Private_Type (Init_Typ)
+                  and then Present (Full_View (Init_Typ))
+               then
+                  Init_Typ := Full_View (Init_Typ);
+
+               elsif Is_Untagged_Derivation (Init_Typ)
+                 and then not Is_Conc
+               then
+                  Init_Typ := Root_Type (Init_Typ);
+
+               else
+                  exit;
+               end if;
+            end loop;
+
+            if Init_Typ /= Base_Type (Init_Typ) then
+               Init_Typ := Base_Type (Init_Typ);
             end if;
 
+            Stmt := Next_Suitable_Statement (Decl);
+
             --  A limited controlled object initialized by a function call uses
             --  the build-in-place machinery to obtain its value.
 
@@ -2381,11 +2442,10 @@ package body Exp_Ch7 is
             --  In this scenario the declaration of the temporary acts as the
             --  last initialization statement.
 
-            if Is_Limited_Type (Utyp)
+            if Is_Limited_Type (Init_Typ)
               and then Has_Init_Expression (Decl)
               and then No (Expression (Decl))
             then
-               Stmt := Next (Decl);
                while Present (Stmt) loop
                   if Nkind (Stmt) = N_Object_Declaration
                     and then Present (Expression (Stmt))
@@ -2400,68 +2460,77 @@ package body Exp_Ch7 is
                   Next (Stmt);
                end loop;
 
-            --  The init procedures are arranged as follows:
-
-            --    Object : Controlled_Type;
-            --    Controlled_TypeIP (Object);
-            --    [[Deep_]Initialize (Object);]
-
-            --  where the user-defined initialize may be optional or may appear
-            --  inside a block when abort deferral is needed.
+            --  In all other cases the initialization calls follow the related
+            --  object. The general structure of object initialization built by
+            --  routine Default_Initialize_Object is as follows:
+
+            --   [begin                                --  aborts allowed
+            --       Abort_Defer;]
+            --       Type_Init_Proc (Obj);
+            --      [begin]                            --  exceptions allowed
+            --          Deep_Initialize (Obj);
+            --      [exception                         --  exceptions allowed
+            --          when others =>
+            --             Deep_Finalize (Obj, Self => False);
+            --             raise;
+            --       end;]
+            --   [at end                               --  aborts allowed
+            --       Abort_Undefer;
+            --    end;]
+
+            --  When aborts are allowed, the initialization calls are housed
+            --  within a block.
+
+            elsif Nkind (Stmt) = N_Block_Statement then
+               Last_Init   := Find_Last_Init_In_Block (Stmt, Init_Typ);
+               Body_Insert := Stmt;
+
+            --  Otherwise the initialization calls follow the related object
 
             else
-               Nod_1 := Next_Suitable_Statement (Decl);
-
-               if Present (Nod_1) then
-                  Nod_2 := Next_Suitable_Statement (Nod_1);
+               Stmt_2 := Next_Suitable_Statement (Stmt);
 
-                  --  The statement following an object declaration is always a
-                  --  call to the type init proc.
+               --  Check for an optional call to Deep_Initialize which may
+               --  appear within a block depending on whether the object has
+               --  controlled components.
 
-                  Last_Init := Nod_1;
-               end if;
-
-               --  Optional user-defined init or deep init processing
-
-               if Present (Nod_2) then
-
-                  --  The statement following the type init proc may be a block
-                  --  statement in cases where abort deferral is required.
-
-                  if Nkind (Nod_2) = N_Block_Statement then
-                     declare
-                        HSS  : constant Node_Id :=
-                                 Handled_Statement_Sequence (Nod_2);
-                        Stmt : Node_Id;
-
-                     begin
-                        if Present (HSS)
-                          and then Present (Statements (HSS))
-                        then
-                           --  Examine individual block statements and locate
-                           --  the call to [Deep_]Initialze.
+               if Present (Stmt_2) then
+                  if Nkind (Stmt_2) = N_Block_Statement then
+                     Call := Find_Last_Init_In_Block (Stmt_2, Init_Typ);
 
-                           Stmt := First (Statements (HSS));
-                           while Present (Stmt) loop
-                              if Is_Init_Call (Stmt, Utyp) then
-                                 Last_Init   := Stmt;
-                                 Body_Insert := Nod_2;
+                     if Present (Call) then
+                        Last_Init   := Call;
+                        Body_Insert := Stmt_2;
+                     end if;
 
-                                 exit;
-                              end if;
+                  elsif Is_Init_Call (Stmt_2, Init_Typ) then
+                     Last_Init   := Stmt_2;
+                     Body_Insert := Last_Init;
+                  end if;
 
-                              Next (Stmt);
-                           end loop;
-                        end if;
-                     end;
+               --  If the object lacks a call to Deep_Initialize, then it must
+               --  have a call to its related type init proc.
 
-                  elsif Is_Init_Call (Nod_2, Utyp) then
-                     Last_Init := Nod_2;
-                  end if;
+               elsif Is_Init_Call (Stmt, Init_Typ) then
+                  Last_Init   := Stmt;
+                  Body_Insert := Last_Init;
                end if;
             end if;
          end Find_Last_Init;
 
+         --  Local variables
+
+         Obj_Id    : constant Entity_Id := Defining_Identifier (Decl);
+         Body_Ins  : Node_Id;
+         Count_Ins : Node_Id;
+         Fin_Call  : Node_Id;
+         Fin_Stmts : List_Id;
+         Inc_Decl  : Node_Id;
+         Label     : Node_Id;
+         Label_Id  : Entity_Id;
+         Obj_Ref   : Node_Id;
+         Obj_Typ   : Entity_Id;
+
       --  Start of processing for Process_Object_Declaration
 
       begin
@@ -2492,7 +2561,7 @@ package body Exp_Ch7 is
          --  initialized via an aggregate, then the counter must be inserted
          --  after the last aggregate assignment.
 
-         if Ekind (Obj_Id) = E_Variable
+         if Ekind_In (Obj_Id, E_Constant, E_Variable)
            and then Present (Last_Aggregate_Assignment (Obj_Id))
          then
             Count_Ins := Last_Aggregate_Assignment (Obj_Id);
@@ -2502,7 +2571,7 @@ package body Exp_Ch7 is
          --  either [Deep_]Initialize or the type specific init proc.
 
          else
-            Find_Last_Init (Decl, Obj_Typ, Count_Ins, Body_Ins);
+            Find_Last_Init (Decl, Count_Ins, Body_Ins);
          end if;
 
          Insert_After (Count_Ins, Inc_Decl);
@@ -2526,7 +2595,7 @@ package body Exp_Ch7 is
          end if;
 
          --  Create the associated label with this object, generate:
-         --
+
          --    L<counter> : label;
 
          Label_Id :=
@@ -2541,7 +2610,7 @@ package body Exp_Ch7 is
              Label_Construct     => Label));
 
          --  Create the associated jump with this object, generate:
-
+         --
          --    when <counter> =>
          --       goto L<counter>;
 
@@ -2685,7 +2754,8 @@ package body Exp_Ch7 is
                   if Is_Build_In_Place_Function (Func_Id)
                     and then Needs_BIP_Finalization_Master (Func_Id)
                   then
-                     Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
+                     Append_To
+                       (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id, Obj_Id));
                   end if;
                end;
             end if;
@@ -4933,9 +5003,9 @@ package body Exp_Ch7 is
    -----------------------
 
    function Make_Adjust_Call
-     (Obj_Ref    : Node_Id;
-      Typ        : Entity_Id;
-      For_Parent : Boolean := False) return Node_Id
+     (Obj_Ref   : Node_Id;
+      Typ       : Entity_Id;
+      Skip_Self : Boolean := False) return Node_Id
    is
       Loc    : constant Source_Ptr := Sloc (Obj_Ref);
       Adj_Id : Entity_Id := Empty;
@@ -4972,11 +5042,13 @@ package body Exp_Ch7 is
          Ref  := Unchecked_Convert_To (Utyp, Ref);
       end if;
 
-      --  Select the appropriate version of adjust
-
-      if For_Parent then
+      if Skip_Self then
          if Has_Controlled_Component (Utyp) then
-            Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
+            if Is_Tagged_Type (Utyp) then
+               Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
+            else
+               Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
+            end if;
          end if;
 
       --  Class-wide types, interfaces and types with controlled components
@@ -5027,7 +5099,11 @@ package body Exp_Ch7 is
             Ref := Convert_View (Adj_Id, Ref);
          end if;
 
-         return Make_Call (Loc, Adj_Id, New_Copy_Tree (Ref), For_Parent);
+         return
+           Make_Call (Loc,
+             Proc_Id   => Adj_Id,
+             Param     => New_Copy_Tree (Ref),
+             Skip_Self => Skip_Self);
       else
          return Empty;
       end if;
@@ -5075,19 +5151,18 @@ package body Exp_Ch7 is
    ---------------
 
    function Make_Call
-     (Loc        : Source_Ptr;
-      Proc_Id    : Entity_Id;
-      Param      : Node_Id;
-      For_Parent : Boolean := False) return Node_Id
+     (Loc       : Source_Ptr;
+      Proc_Id   : Entity_Id;
+      Param     : Node_Id;
+      Skip_Self : Boolean := False) return Node_Id
    is
       Params : constant List_Id := New_List (Param);
 
    begin
-      --  When creating a call to Deep_Finalize for a _parent field of a
-      --  derived type, disable the invocation of the nested Finalize by giving
-      --  the corresponding flag a False value.
+      --  Do not apply the controlled action to the object itself by signaling
+      --  the related routine to avoid self.
 
-      if For_Parent then
+      if Skip_Self then
          Append_To (Params, New_Occurrence_Of (Standard_False, Loc));
       end if;
 
@@ -6307,13 +6382,13 @@ package body Exp_Ch7 is
                if Needs_Finalization (Par_Typ) then
                   Call :=
                     Make_Adjust_Call
-                      (Obj_Ref    =>
+                      (Obj_Ref   =>
                          Make_Selected_Component (Loc,
                            Prefix        => Make_Identifier (Loc, Name_V),
                            Selector_Name =>
                              Make_Identifier (Loc, Name_uParent)),
-                       Typ        => Par_Typ,
-                       For_Parent => True);
+                       Typ       => Par_Typ,
+                       Skip_Self => True);
 
                   --  Generate:
                   --    Deep_Adjust (V._parent, False);  --  No_Except_Propagat
@@ -6882,13 +6957,13 @@ package body Exp_Ch7 is
                if Needs_Finalization (Par_Typ) then
                   Call :=
                     Make_Final_Call
-                      (Obj_Ref    =>
+                      (Obj_Ref   =>
                          Make_Selected_Component (Loc,
                            Prefix        => Make_Identifier (Loc, Name_V),
                            Selector_Name =>
                              Make_Identifier (Loc, Name_uParent)),
-                       Typ        => Par_Typ,
-                       For_Parent => True);
+                       Typ       => Par_Typ,
+                       Skip_Self => True);
 
                   --  Generate:
                   --    Deep_Finalize (V._parent, False);  --  No_Except_Propag
@@ -7118,9 +7193,9 @@ package body Exp_Ch7 is
    ----------------------
 
    function Make_Final_Call
-     (Obj_Ref    : Node_Id;
-      Typ        : Entity_Id;
-      For_Parent : Boolean := False) return Node_Id
+     (Obj_Ref   : Node_Id;
+      Typ       : Entity_Id;
+      Skip_Self : Boolean := False) return Node_Id
    is
       Loc    : constant Source_Ptr := Sloc (Obj_Ref);
       Atyp   : Entity_Id;
@@ -7203,11 +7278,13 @@ package body Exp_Ch7 is
          Set_Assignment_OK (Ref);
       end if;
 
-      --  Select the appropriate version of Finalize
-
-      if For_Parent then
+      if Skip_Self then
          if Has_Controlled_Component (Utyp) then
-            Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
+            if Is_Tagged_Type (Utyp) then
+               Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
+            else
+               Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
+            end if;
          end if;
 
       --  Class-wide types, interfaces and types with controlled components
@@ -7278,7 +7355,11 @@ package body Exp_Ch7 is
             Ref := Convert_View (Fin_Id, Ref);
          end if;
 
-         return Make_Call (Loc, Fin_Id, New_Copy_Tree (Ref), For_Parent);
+         return
+           Make_Call (Loc,
+             Proc_Id   => Fin_Id,
+             Param     => New_Copy_Tree (Ref),
+             Skip_Self => Skip_Self);
       else
          return Empty;
       end if;
diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads
index 86faac934b4..1217e5b5f3b 100644
--- a/gcc/ada/exp_ch7.ads
+++ b/gcc/ada/exp_ch7.ads
@@ -162,14 +162,14 @@ package Exp_Ch7 is
    --  latest extension contains a controlled component.
 
    function Make_Adjust_Call
-     (Obj_Ref    : Node_Id;
-      Typ        : Entity_Id;
-      For_Parent : Boolean := False) return Node_Id;
+     (Obj_Ref   : Node_Id;
+      Typ       : Entity_Id;
+      Skip_Self : Boolean := False) return Node_Id;
    --  Create a call to either Adjust or Deep_Adjust depending on the structure
    --  of type Typ. Obj_Ref is an expression with no-side effect (not required
    --  to have been previously analyzed) that references the object to be
-   --  adjusted. Typ is the expected type of Obj_Ref. Flag For_Parent must be
-   --  set when an adjustment call is being created for field _parent.
+   --  adjusted. Typ is the expected type of Obj_Ref. When Skip_Self is set,
+   --  only the components (if any) are adjusted.
 
    function Make_Attach_Call
      (Obj_Ref : Node_Id;
@@ -191,15 +191,14 @@ package Exp_Ch7 is
    --      (System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref));
 
    function Make_Final_Call
-     (Obj_Ref    : Node_Id;
-      Typ        : Entity_Id;
-      For_Parent : Boolean := False) return Node_Id;
+     (Obj_Ref   : Node_Id;
+      Typ       : Entity_Id;
+      Skip_Self : Boolean := False) return Node_Id;
    --  Create a call to either Finalize or Deep_Finalize depending on the
-   --  structure of type Typ. Obj_Ref is an expression (with no-side effect and
-   --  is not required to have been previously analyzed) that references the
-   --  object to be finalized. Typ is the expected type of Obj_Ref. Flag For_
-   --  Parent must be set when a finalization call is being created for field
-   --  _parent.
+   --  structure of type Typ. Obj_Ref is an expression (with no-side effect
+   --  and is not required to have been previously analyzed) that references
+   --  the object to be finalized. Typ is the expected type of Obj_Ref. When
+   --  Skip_Self is set, only the components (if any) are finalized.
 
    procedure Make_Finalize_Address_Body (Typ : Entity_Id);
    --  Create the body of TSS routine Finalize_Address if Typ is controlled and
@@ -300,7 +299,12 @@ package Exp_Ch7 is
    procedure Store_After_Actions_In_Scope (L : List_Id);
    --  Prepend the list L of actions to the beginning of the after-actions
    --  stored in the top of the scope stack (also analyzes these actions).
-   --  Why prepend rather than append ???
+   --
+   --  Note that we are prepending here rather than appending. This means that
+   --  if several calls are made to this procedure for the same scope, the
+   --  actions will be executed in reverse order of the calls (actions for the
+   --  last call executed first). Within the list L for a single call, the
+   --  actions are executed in the order in which they appear in this list.
 
    procedure Store_Cleanup_Actions_In_Scope (L : List_Id);
    --  Prepend the list L of actions to the beginning of the cleanup-actions
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index 9dcd7de94aa..fb479561ed4 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -2436,10 +2436,11 @@ package body Sem_Ch9 is
 
       --  AI05-0225: the target protected object of a requeue must be a
       --  variable. This is a binding interpretation that applies to all
-      --  versions of the language.
+      --  versions of the language. Note that the subprogram does not have
+      --  to be a protected operation: it can be an primitive implemented
+      --  by entry with a formal that is a protected interface.
 
       if Present (Target_Obj)
-        and then Ekind (Scope (Entry_Id)) in Protected_Kind
         and then not Is_Variable (Target_Obj)
       then
          Error_Msg_N