ada: Streamline expansion of controlled actions for aggregates

This changes the strategy used to expand controlled actions for array and
record aggregates so as to make it simpler and more robust.

The current strategy is to set the No_Ctrl_Actions flag on the assignments
generated during the expansion of aggregate, as done during the expansion
of initialization procedures, and to generate the adjustments of the LHS
manually in the same list of actions, before sending the entire list for
analysis and expansion.  The problem is that, when the RHS also requires
controlled actions, the No_Ctrl_Actions flag prevents transient scopes
from being created around the assignments, with the end result that the
actions are "naturally" generated between the assignments and adjustments
of the LHS, causing premature finalization of the RHS.  In order to counter
that, the controlled actions of the RHS must also be generated manually
during the expansion of the aggregates, after blocking normal processing
e.g. by means of the No_Side_Effect_Removal flag.  This means that, for
a more complex RHS, this strategy generates a wrong order of controlled
actions by default, until specifically adjusted.

The new strategy is to reuse the standard machinery as much as possible,
disabling only the part that is not needed for the assignments generated
during the expansion of aggregates, namely the finalization of the LHS;
in other words, the adjustment of the LHS is left entirely to the standard
machinery and the creation of transient scopes is no longer blocked, which
gives a correct order of controlled actions by default.  It is implemented
by means of a No_Finalize_Actions flag present on the assignments generated
during the expansion.

It is mostly straightforward, modulo the following hitch: the assignments
are now analyzed and expanded by the common expander, which in the case of
controlled assignments analyzes the final rewriting with all checks off,
which in particular disables elaboration checks for the calls to the Adjust
primitives; now these checks are necessary in the case where an aggregate
is the initialization expression of an object declared before the body of
the Adjust primitive is seen.  Hence the use of an existing trick, namely
Suppress/Unsuppress blocks, around the assignments.

gcc/ada/

	* gen_il-fields.ads (Opt_Field_Enum): Add No_Finalize_Actions and
	remove No_Side_Effect_Removal.
	* gen_il-gen-gen_nodes.adb (N_Function_Call): Remove semantic flag
	No_Side_Effect_Removal
	(N_Assignment_Statement): Add semantic flag No_Finalize_Actions.
	* sinfo.ads (No_Ctrl_Actions): Adjust comment.
	(No_Finalize_Actions): New flag on assignment statements.
	(No_Side_Effect_Removal): Delete.
	* exp_aggr.adb (Build_Record_Aggr_Code): Remove obsolete comment and
	Ancestor_Is_Expression variable.  In the case of an extension, do
	not generate a call to Adjust manually, call Set_No_Finalize_Actions
	instead.  Do not set the tags, replace call to Make_Unsuppress_Block
	by Make_Suppress_Block and remove useless assertions.
	In the general case, call Initialize_Component.
	(Initialize_Controlled_Component): Delete.
	(Initialize_Simple_Component): Delete.
	(Initialize_Component): Do the low-level processing, but do not
	generate a call to Adjust manually, call Set_No_Finalize_Actions.
	(Process_Transient_Component): Delete.
	(Process_Transient_Component_Completion): Likewise.
	* exp_ch5.adb (Expand_Assign_Array): Deal with No_Finalize_Actions.
	(Expand_Assign_Array_Loop): Likewise.
	(Expand_N_Assignment_Statement): Likewise.
	(Make_Tag_Ctrl_Assignment): Likewise.
	* exp_util.adb (Remove_Side_Effects): Do not test the
	No_Side_Effect_Removal flag.
	* sem_prag.adb (Process_Suppress_Unsuppress): Give the warning in
	SPARK mode only for pragma Suppress.
	* tbuild.ads (Make_Suppress_Block): New declaration.
	(Make_Unsuppress_Block): Adjust comment.
	* tbuild.adb (Make_Suppress_Block): New procedure.
	(Make_Unsuppress_Block): Unsuppress instead of suppressing.

1 files changed, 42 insertions, 13 deletions

diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 2be6e7e..d8214bd 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -952,6 +952,7 @@ package body Exp_Ch5 is
               and then Base_Type (L_Type) = Base_Type (R_Type)
               and then Ndim = 1
               and then not No_Ctrl_Actions (N)
+              and then not No_Finalize_Actions (N)
             then
                declare
                   Proc    : constant Entity_Id :=
@@ -1097,8 +1098,8 @@ package body Exp_Ch5 is
               and then Base_Type (L_Type) = Base_Type (R_Type)
               and then Ndim = 1
               and then not No_Ctrl_Actions (N)
+              and then not No_Finalize_Actions (N)
             then
-
                --  Call TSS procedure for array assignment, passing the
                --  explicit bounds of right- and left-hand sides.
 
@@ -1321,9 +1322,10 @@ package body Exp_Ch5 is
 
          Set_Assignment_OK (Name (Assign));
 
-         --  Propagate the No_Ctrl_Actions flag to individual assignments
+         --  Propagate the No_{Ctrl,Finalize}_Actions flags to assignments
 
-         Set_No_Ctrl_Actions (Assign, No_Ctrl_Actions (N));
+         Set_No_Ctrl_Actions     (Assign, No_Ctrl_Actions (N));
+         Set_No_Finalize_Actions (Assign, No_Finalize_Actions (N));
       end;
 
       --  Now construct the loop from the inside out, with the last subscript
@@ -2963,7 +2965,9 @@ package body Exp_Ch5 is
       then
          Tagged_Case : declare
             L                   : List_Id := No_List;
-            Expand_Ctrl_Actions : constant Boolean := not No_Ctrl_Actions (N);
+            Expand_Ctrl_Actions : constant Boolean
+                                    := not No_Ctrl_Actions (N)
+                                         and then not No_Finalize_Actions (N);
 
          begin
             --  In the controlled case, we ensure that function calls are
@@ -3163,10 +3167,20 @@ package body Exp_Ch5 is
                end if;
             end if;
 
-            Rewrite (N,
-              Make_Block_Statement (Loc,
-                Handled_Statement_Sequence =>
-                  Make_Handled_Sequence_Of_Statements (Loc, Statements => L)));
+            --  We will analyze the block statement with all checks suppressed
+            --  below, but we need elaboration checks for the primitives in the
+            --  case of an assignment created by the expansion of an aggregate.
+
+            if No_Finalize_Actions (N) then
+               Rewrite (N,
+                 Make_Unsuppress_Block (Loc, Name_Elaboration_Check, L));
+
+            else
+               Rewrite (N,
+                 Make_Block_Statement (Loc,
+                   Handled_Statement_Sequence =>
+                    Make_Handled_Sequence_Of_Statements (Loc, L)));
+            end if;
 
             --  If no restrictions on aborts, protect the whole assignment
             --  for controlled objects as per 9.8(11).
@@ -6240,12 +6254,20 @@ package body Exp_Ch5 is
       Res : constant List_Id    := New_List;
       T   : constant Entity_Id  := Underlying_Type (Etype (L));
 
+      Adj_Act  : constant Boolean := Needs_Finalization (T)
+                                       and then not No_Ctrl_Actions (N);
       Comp_Asn : constant Boolean := Is_Fully_Repped_Tagged_Type (T);
       Ctrl_Act : constant Boolean := Needs_Finalization (T)
-                                       and then not No_Ctrl_Actions (N);
+                                       and then not No_Ctrl_Actions (N)
+                                       and then not No_Finalize_Actions (N);
       Save_Tag : constant Boolean := Is_Tagged_Type (T)
                                        and then not Comp_Asn
                                        and then not No_Ctrl_Actions (N)
+                                       and then not No_Finalize_Actions (N)
+                                       and then Tagged_Type_Expansion;
+      Set_Tag  : constant Boolean := Is_Tagged_Type (T)
+                                       and then not Comp_Asn
+                                       and then not No_Ctrl_Actions (N)
                                        and then Tagged_Type_Expansion;
       Adj_Call : Node_Id;
       Fin_Call : Node_Id;
@@ -6256,8 +6278,8 @@ package body Exp_Ch5 is
 
       --  We have two exceptions here:
 
-      --   1. If we are in an init proc since it is an initialization more
-      --      than an assignment.
+      --   1. If we are in an init proc or within an aggregate, since it is an
+      --      initialization more than an assignment.
 
       --   2. If the left-hand side is a temporary that was not initialized
       --      (or the parent part of a temporary since it is the case in
@@ -6266,7 +6288,7 @@ package body Exp_Ch5 is
       --      it may be a component of an entry formal, in which case it has
       --      been rewritten and does not appear to come from source either.
 
-      --  Case of init proc
+      --  Case of init proc or aggregate
 
       if not Ctrl_Act then
          null;
@@ -6336,12 +6358,19 @@ package body Exp_Ch5 is
                  Selector_Name =>
                    New_Occurrence_Of (First_Tag_Component (T), Loc)),
              Expression => New_Occurrence_Of (Tag_Id, Loc)));
+
+      --  Or else just initialize it
+
+      elsif Set_Tag then
+         Append_To (Res,
+           Make_Tag_Assignment_From_Type
+             (Loc, Duplicate_Subexpr_No_Checks (L), T));
       end if;
 
       --  Adjust the target after the assignment when controlled (not in the
       --  init proc since it is an initialization more than an assignment).
 
-      if Ctrl_Act then
+      if Ctrl_Act or else Adj_Act then
          Adj_Call :=
            Make_Adjust_Call
              (Obj_Ref => Duplicate_Subexpr_Move_Checks (L),