public inbox for gcc-patches@gcc.gnu.org
 help / color / mirror / Atom feed
* [COMMITTED] ada: Streamline expansion of controlled actions for aggregates
@ 2023-06-13  7:38 Marc Poulhiès
  0 siblings, 0 replies; only message in thread
From: Marc Poulhiès @ 2023-06-13  7:38 UTC (permalink / raw)
  To: gcc-patches; +Cc: Eric Botcazou

From: Eric Botcazou <ebotcazou@adacore.com>

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.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/exp_aggr.adb             | 740 ++-----------------------------
 gcc/ada/exp_ch5.adb              |  55 ++-
 gcc/ada/exp_util.adb             |   8 -
 gcc/ada/gen_il-fields.ads        |   2 +-
 gcc/ada/gen_il-gen-gen_nodes.adb |   4 +-
 gcc/ada/sem_prag.adb             |   5 +-
 gcc/ada/sinfo.ads                |  31 +-
 gcc/ada/tbuild.adb               |  36 +-
 gcc/ada/tbuild.ads               |  11 +-
 9 files changed, 142 insertions(+), 750 deletions(-)

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index dcbf2c4981d..fb5f404922f 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -106,33 +106,13 @@ package body Exp_Aggr is
    --  initialization (<>) in any component (Ada 2005: AI-287).
 
    procedure Initialize_Component
-     (N         : Node_Id;
-      Comp      : Node_Id;
-      Comp_Typ  : Entity_Id;
-      Init_Expr : Node_Id;
-      Stmts     : List_Id);
-   --  Perform the initialization of component Comp with expected type Comp_Typ
-   --  of aggregate N. Init_Expr denotes the initialization expression of the
-   --  component. All generated code is added to Stmts.
-
-   procedure Initialize_Controlled_Component
-     (N         : Node_Id;
-      Comp      : Node_Id;
-      Comp_Typ  : Entity_Id;
-      Init_Expr : Node_Id;
-      Stmts     : List_Id);
-   --  Perform the initialization of controlled component Comp with expected
-   --  type Comp_Typ of aggregate N. Init_Expr denotes the initialization
-   --  expression of the component. All generated code is added to Stmts.
-
-   procedure Initialize_Simple_Component
      (N         : Node_Id;
       Comp      : Node_Id;
       Comp_Typ  : Node_Id;
       Init_Expr : Node_Id;
       Stmts     : List_Id);
-    --  Perform the initialization of simple component Comp with expected
-    --  type Comp_Typ of aggregate N. Init_Expr denotes the initialization
+    --  Perform the initialization of component Comp with expected type
+    --  Comp_Typ of aggregate N. Init_Expr denotes the initialization
     --  expression of the component. All generated code is added to Stmts.
 
    function Is_CCG_Supported_Aggregate (N : Node_Id) return Boolean;
@@ -181,37 +161,6 @@ package body Exp_Aggr is
    --  Returns the number of discrete choices (not including the others choice
    --  if present) contained in (sub-)aggregate N.
 
-   procedure Process_Transient_Component
-     (Loc        : Source_Ptr;
-      Comp_Typ   : Entity_Id;
-      Init_Expr  : Node_Id;
-      Fin_Call   : out Node_Id;
-      Hook_Clear : out Node_Id;
-      Aggr       : Node_Id := Empty;
-      Stmts      : List_Id := No_List);
-   --  Subsidiary to the expansion of array and record aggregates. Generate
-   --  part of the necessary code to finalize a transient component. Comp_Typ
-   --  is the component type. Init_Expr is the initialization expression of the
-   --  component which is always a function call. Fin_Call is the finalization
-   --  call used to clean up the transient function result. Hook_Clear is the
-   --  hook reset statement. Aggr and Stmts both control the placement of the
-   --  generated code. Aggr is the related aggregate. If present, all code is
-   --  inserted prior to Aggr using Insert_Action. Stmts is the initialization
-   --  statements of the component. If present, all code is added to Stmts.
-
-   procedure Process_Transient_Component_Completion
-     (Loc        : Source_Ptr;
-      Aggr       : Node_Id;
-      Fin_Call   : Node_Id;
-      Hook_Clear : Node_Id;
-      Stmts      : List_Id);
-   --  Subsidiary to the expansion of array and record aggregates. Generate
-   --  part of the necessary code to finalize a transient component. Aggr is
-   --  the related aggregate. Fin_Clear is the finalization call used to clean
-   --  up the transient component. Hook_Clear is the hook reset statement.
-   --  Stmts is the initialization statement list for the component. All
-   --  generated code is added to Stmts.
-
    procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
    --  Sort the Case Table using the Lower Bound of each Choice as the key.
    --  A simple insertion sort is used since the number of choices in a case
@@ -2242,14 +2191,6 @@ package body Exp_Aggr is
       Comp_Expr : Node_Id;
       Expr_Q    : Node_Id;
 
-      --  If this is an internal aggregate, the External_Final_List is an
-      --  expression for the controller record of the enclosing type.
-
-      --  If the current aggregate has several controlled components, this
-      --  expression will appear in several calls to attach to the finali-
-      --  zation list, and it must not be shared.
-
-      Ancestor_Is_Expression   : Boolean := False;
       Ancestor_Is_Subtype_Mark : Boolean := False;
 
       Init_Typ : Entity_Id := Empty;
@@ -2894,9 +2835,7 @@ package body Exp_Aggr is
       --  to the actual type of the aggregate, so that the proper components
       --  are visible. We know already that the types are compatible.
 
-      if Present (Etype (Lhs))
-        and then Is_Class_Wide_Type (Etype (Lhs))
-      then
+      if Present (Etype (Lhs)) and then Is_Class_Wide_Type (Etype (Lhs)) then
          Target := Unchecked_Convert_To (Typ, Lhs);
       else
          Target := Lhs;
@@ -2910,7 +2849,6 @@ package body Exp_Aggr is
             Ancestor   : constant Node_Id := Ancestor_Part (N);
             Ancestor_Q : constant Node_Id := Unqualify (Ancestor);
 
-            Adj_Call : Node_Id;
             Assign   : List_Id;
 
          begin
@@ -3057,7 +2995,6 @@ package body Exp_Aggr is
             --  Make_Build_In_Place_Call_In_Assignment).
 
             else
-               Ancestor_Is_Expression := True;
                Init_Typ := Etype (Ancestor);
 
                --  If the ancestor part is an aggregate, force its full
@@ -3071,69 +3008,29 @@ package body Exp_Aggr is
 
                Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
 
-               --  Make the assignment without usual controlled actions, since
-               --  we only want to Adjust afterwards, but not to Finalize
-               --  beforehand. Add manual Adjust when necessary.
-
                Assign := New_List (
                  Make_OK_Assignment_Statement (Loc,
                    Name       => Ref,
                    Expression => Ancestor));
-               Set_No_Ctrl_Actions (First (Assign));
-
-               --  Assign the tag now to make sure that the dispatching call in
-               --  the subsequent deep_adjust works properly (unless
-               --  Tagged_Type_Expansion where tags are implicit).
-
-               if Tagged_Type_Expansion then
-                  Instr :=
-                    Make_Tag_Assignment_From_Type
-                      (Loc, New_Copy_Tree (Target), Base_Type (Typ));
-
-                  Append_To (Assign, Instr);
-
-                  --  Ada 2005 (AI-251): If tagged type has progenitors we must
-                  --  also initialize tags of the secondary dispatch tables.
-
-                  if Has_Interfaces (Base_Type (Typ)) then
-                     Init_Secondary_Tags
-                       (Typ            => Base_Type (Typ),
-                        Target         => Target,
-                        Stmts_List     => Assign,
-                        Init_Tags_List => Assign);
-                  end if;
-               end if;
 
-               --  Call Adjust manually
+               --  Arrange for the component to be adjusted if need be (the
+               --  call will be generated by Make_Tag_Ctrl_Assignment).
 
                if Needs_Finalization (Init_Typ)
-                 and then not Is_Limited_Type (Init_Typ)
-                 and then not Is_Build_In_Place_Function_Call (Ancestor)
+                 and then not Is_Limited_View (Init_Typ)
                then
-                  Adj_Call :=
-                    Make_Adjust_Call
-                      (Obj_Ref => New_Copy_Tree (Ref),
-                       Typ     => Init_Typ);
-
-                  --  Guard against a missing [Deep_]Adjust when the ancestor
-                  --  type was not properly frozen.
-
-                  if Present (Adj_Call) then
-                     Append_To (Assign, Adj_Call);
-                  end if;
+                  Set_No_Finalize_Actions (First (Assign));
+               else
+                  Set_No_Ctrl_Actions (First (Assign));
                end if;
 
                Append_To (L,
-                 Make_Unsuppress_Block (Loc, Name_Discriminant_Check, Assign));
+                 Make_Suppress_Block (Loc, Name_Discriminant_Check, Assign));
 
                if Has_Discriminants (Init_Typ) then
                   Check_Ancestor_Discriminants (Init_Typ);
                end if;
             end if;
-
-            pragma Assert (Nkind (N) = N_Extension_Aggregate);
-            pragma Assert
-              (not (Ancestor_Is_Expression and Ancestor_Is_Subtype_Mark));
          end;
 
          --  Generate assignments of hidden discriminants. If the base type is
@@ -3260,7 +3157,7 @@ package body Exp_Aggr is
                 Prefix        => New_Copy_Tree (Target),
                 Selector_Name => New_Occurrence_Of (Selector, Loc));
 
-            Initialize_Simple_Component
+            Initialize_Component
               (N         => N,
                Comp      => Comp_Expr,
                Comp_Typ  => Etype (Selector),
@@ -3591,21 +3488,18 @@ package body Exp_Aggr is
          Next (Comp);
       end loop;
 
-      --  If the type is tagged, the tag needs to be initialized (unless we
-      --  are in VM-mode where tags are implicit). It is done late in the
-      --  initialization process because in some cases, we call the init
-      --  proc of an ancestor which will not leave out the right tag.
-
-      if Ancestor_Is_Expression then
-         null;
-
       --  For CPP types we generated a call to the C++ default constructor
       --  before the components have been initialized to ensure the proper
       --  initialization of the _Tag component (see above).
 
-      elsif Is_CPP_Class (Typ) then
+      if Is_CPP_Class (Typ) then
          null;
 
+      --  If the type is tagged, the tag needs to be initialized (unless we
+      --  are in VM-mode where tags are implicit). It is done late in the
+      --  initialization process because in some cases, we call the init
+      --  proc of an ancestor which will not leave out the right tag.
+
       elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
          Instr :=
            Make_Tag_Assignment_From_Type
@@ -8408,261 +8302,6 @@ package body Exp_Aggr is
    --------------------------
 
    procedure Initialize_Component
-     (N         : Node_Id;
-      Comp      : Node_Id;
-      Comp_Typ  : Entity_Id;
-      Init_Expr : Node_Id;
-      Stmts     : List_Id)
-   is
-      Init_Expr_Q : constant Node_Id    := Unqualify (Init_Expr);
-      Loc         : constant Source_Ptr := Sloc (N);
-
-   begin
-      --  If the initialization expression of a component with controlled type
-      --  is a conditional expression that has a function call as one of its
-      --  dependent expressions, then we need to expand it immediately, so as
-      --  to trigger the special processing for function calls with controlled
-      --  type below and avoid a wrong order of initialization, adjustment and
-      --  finalization in the context of aggregates. For the sake of uniformity
-      --  we perform this expansion for all conditional expressions.
-
-      if Nkind (Init_Expr_Q) = N_If_Expression
-        and then Present (Comp_Typ)
-        and then Needs_Finalization (Comp_Typ)
-      then
-         declare
-            Cond       : constant Node_Id := First (Expressions (Init_Expr_Q));
-            Thenx      : constant Node_Id := Next (Cond);
-            Elsex      : constant Node_Id := Next (Thenx);
-            Then_Stmts : constant List_Id := New_List;
-            Else_Stmts : constant List_Id := New_List;
-
-            If_Stmt : Node_Id;
-
-         begin
-            Initialize_Component
-              (N         => N,
-               Comp      => Comp,
-               Comp_Typ  => Comp_Typ,
-               Init_Expr => Thenx,
-               Stmts     => Then_Stmts);
-
-            Initialize_Component
-              (N         => N,
-               Comp      => Comp,
-               Comp_Typ  => Comp_Typ,
-               Init_Expr => Elsex,
-               Stmts     => Else_Stmts);
-
-            If_Stmt :=
-              Make_Implicit_If_Statement (N,
-                Condition       => Relocate_Node (Cond),
-                Then_Statements => Then_Stmts,
-                Else_Statements => Else_Stmts);
-
-            Set_From_Conditional_Expression (If_Stmt);
-            Append_To (Stmts, If_Stmt);
-         end;
-
-      elsif Nkind (Init_Expr_Q) = N_Case_Expression
-        and then Present (Comp_Typ)
-        and then Needs_Finalization (Comp_Typ)
-      then
-         declare
-            Alt       : Node_Id;
-            Alt_Stmts : List_Id;
-            Case_Stmt : Node_Id;
-
-         begin
-            Case_Stmt :=
-               Make_Case_Statement (Loc,
-                 Expression   =>
-                   Relocate_Node (Expression (Init_Expr_Q)),
-                 Alternatives => New_List);
-
-            Alt := First (Alternatives (Init_Expr_Q));
-            while Present (Alt) loop
-               declare
-                  Alt_Expr : constant Node_Id    := Expression (Alt);
-                  Alt_Loc  : constant Source_Ptr := Sloc (Alt_Expr);
-
-               begin
-                  Alt_Stmts := New_List;
-
-                  Initialize_Component
-                    (N         => N,
-                     Comp      => Comp,
-                     Comp_Typ  => Comp_Typ,
-                     Init_Expr => Alt_Expr,
-                     Stmts     => Alt_Stmts);
-
-                  Append_To
-                    (Alternatives (Case_Stmt),
-                     Make_Case_Statement_Alternative (Alt_Loc,
-                     Discrete_Choices => Discrete_Choices (Alt),
-                     Statements       => Alt_Stmts));
-               end;
-
-               Next (Alt);
-            end loop;
-
-            Set_From_Conditional_Expression (Case_Stmt);
-            Append_To (Stmts, Case_Stmt);
-         end;
-
-      --  Handle an initialization expression of a controlled type in
-      --  case it denotes a function call. In general such a scenario
-      --  will produce a transient scope, but this will lead to wrong
-      --  order of initialization, adjustment, and finalization in the
-      --  context of aggregates.
-
-      --    Comp := Ctrl_Func_Call;
-
-      --    begin                                  --  scope
-      --       Trans_Obj : ... := Ctrl_Func_Call;  --  object
-      --       Comp := Trans_Obj;
-      --       Finalize (Trans_Obj);
-      --    end;
-      --    Comp._tag := ...;
-      --    Adjust (Comp (1));
-
-      --  In the example above, the call to Finalize occurs too early
-      --  and as a result it may leave the array component in a bad
-      --  state. Finalization of the transient object should really
-      --  happen after adjustment.
-
-      --  To avoid this scenario, perform in-place side-effect removal
-      --  of the function call. This eliminates the transient property
-      --  of the function result and ensures correct order of actions.
-
-      --    Res : ... := Ctrl_Func_Call;
-      --    Comp := Res;
-      --    Comp._tag := ...;
-      --    Adjust (Comp);
-      --    Finalize (Res);
-
-      elsif Nkind (Init_Expr_Q) /= N_Aggregate
-        and then Present (Comp_Typ)
-        and then Needs_Finalization (Comp_Typ)
-      then
-         Initialize_Controlled_Component
-           (N         => N,
-            Comp      => Comp,
-            Comp_Typ  => Comp_Typ,
-            Init_Expr => Init_Expr,
-            Stmts     => Stmts);
-
-      --  Otherwise perform simple component initialization
-
-      else
-         Initialize_Simple_Component
-           (N         => N,
-            Comp      => Comp,
-            Comp_Typ  => Comp_Typ,
-            Init_Expr => Init_Expr,
-            Stmts     => Stmts);
-      end if;
-   end Initialize_Component;
-
-   -------------------------------------
-   -- Initialize_Controlled_Component --
-   -------------------------------------
-
-   procedure Initialize_Controlled_Component
-     (N         : Node_Id;
-      Comp      : Node_Id;
-      Comp_Typ  : Entity_Id;
-      Init_Expr : Node_Id;
-      Stmts     : List_Id)
-   is
-      Init_Expr_Q : constant Node_Id    := Unqualify (Init_Expr);
-      Loc         : constant Source_Ptr := Sloc (N);
-
-      Fin_Call   : Node_Id;
-      Hook_Clear : Node_Id;
-
-      In_Place_Expansion : Boolean;
-      --  Flag set when a nonlimited controlled function call requires
-      --  in-place expansion.
-
-   begin
-      --  Perform a preliminary analysis and resolution to determine what
-      --  the initialization expression denotes. Unanalyzed function calls
-      --  may appear as identifiers or indexed components.
-
-      if Nkind (Init_Expr_Q) in N_Function_Call
-                              | N_Identifier
-                              | N_Indexed_Component
-        and then not Analyzed (Init_Expr)
-      then
-         Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
-      end if;
-
-      In_Place_Expansion :=
-        Nkind (Init_Expr_Q) = N_Function_Call
-          and then not Is_Build_In_Place_Result_Type (Comp_Typ);
-
-      --  The initialization expression is a controlled function call.
-      --  Perform in-place removal of side effects to avoid creating a
-      --  transient scope.
-
-      --  This in-place expansion is not performed for limited transient
-      --  objects because the initialization is already done in place.
-
-      if In_Place_Expansion then
-
-         --  Suppress the removal of side effects by general analysis
-         --  because this behavior is emulated here. This avoids the
-         --  generation of a transient scope, which leads to out-of-order
-         --  adjustment and finalization.
-
-         Set_No_Side_Effect_Removal (Init_Expr);
-
-         --  Install all hook-related declarations and prepare the clean up
-         --  statements. The generated code follows the initialization order
-         --  of individual components and discriminants, rather than being
-         --  inserted prior to the aggregate. This ensures that a transient
-         --  component which mentions a discriminant has proper visibility
-         --  of the discriminant.
-
-         Process_Transient_Component
-           (Loc        => Loc,
-            Comp_Typ   => Comp_Typ,
-            Init_Expr  => Init_Expr,
-            Fin_Call   => Fin_Call,
-            Hook_Clear => Hook_Clear,
-            Stmts      => Stmts);
-      end if;
-
-      --  Use the simple component initialization circuitry to assign the
-      --  result of the function call to the component. This also performs
-      --  tag adjustment and [deep] adjustment of the component.
-
-      Initialize_Simple_Component
-        (N         => N,
-         Comp      => Comp,
-         Comp_Typ  => Comp_Typ,
-         Init_Expr => Init_Expr,
-         Stmts     => Stmts);
-
-      --  At this point the component is fully initialized. Complete the
-      --  processing by finalizing the transient function result.
-
-      if In_Place_Expansion then
-         Process_Transient_Component_Completion
-           (Loc        => Loc,
-            Aggr       => N,
-            Fin_Call   => Fin_Call,
-            Hook_Clear => Hook_Clear,
-            Stmts      => Stmts);
-      end if;
-   end Initialize_Controlled_Component;
-
-   ---------------------------------
-   -- Initialize_Simple_Component --
-   ---------------------------------
-
-   procedure Initialize_Simple_Component
      (N         : Node_Id;
       Comp      : Node_Id;
       Comp_Typ  : Node_Id;
@@ -8674,10 +8313,8 @@ package body Exp_Aggr is
       Finalization_OK : constant Boolean :=
                           Present (Comp_Typ)
                             and then Needs_Finalization (Comp_Typ);
-      Full_Typ        : constant Entity_Id  := Underlying_Type (Comp_Typ);
       Loc             : constant Source_Ptr := Sloc (N);
 
-      Adj_Call  : Node_Id;
       Blk_Stmts : List_Id;
       Init_Stmt : Node_Id;
 
@@ -8716,48 +8353,33 @@ package body Exp_Aggr is
         Make_OK_Assignment_Statement (Loc,
           Name       => New_Copy_Tree (Comp),
           Expression => Relocate_Node (Init_Expr));
-      Set_No_Ctrl_Actions (Init_Stmt);
 
       Append_To (Blk_Stmts, Init_Stmt);
 
-      --  Adjust the tag due to a possible view conversion. Generate:
-
-      --    Comp._tag := Full_TypeP;
-
-      if Tagged_Type_Expansion
-        and then Present (Comp_Typ)
-        and then Is_Tagged_Type (Comp_Typ)
-      then
-         Append_To (Blk_Stmts,
-           Make_Tag_Assignment_From_Type
-             (Loc, New_Copy_Tree (Comp), Full_Typ));
-      end if;
-
-      --  Adjust the component. In the case of an array aggregate, controlled
-      --  subaggregates are not considered because each of their individual
-      --  elements will receive an adjustment of its own. Generate:
-
-      --    [Deep_]Adjust (Comp);
+      --  Arrange for the component to be adjusted if need be (the call will be
+      --  generated by Make_Tag_Ctrl_Assignment). But, in the case of an array
+      --  aggregate, controlled subaggregates are not considered because each
+      --  of their individual elements will receive an adjustment of its own.
 
       if Finalization_OK
-        and then not Is_Limited_Type (Comp_Typ)
-        and then not Is_Build_In_Place_Function_Call (Init_Expr)
+        and then not Is_Limited_View (Comp_Typ)
         and then not
           (Is_Array_Type (Etype (N))
             and then Is_Array_Type (Comp_Typ)
             and then Needs_Finalization (Component_Type (Comp_Typ))
             and then Nkind (Unqualify (Init_Expr)) = N_Aggregate)
       then
-         Adj_Call :=
-           Make_Adjust_Call
-             (Obj_Ref => New_Copy_Tree (Comp),
-              Typ     => Comp_Typ);
+         Set_No_Finalize_Actions (Init_Stmt);
 
-         --  Guard against a missing [Deep_]Adjust when the component type
-         --  was not properly frozen.
+      --  Or else, only adjust the tag due to a possible view conversion
+
+      else
+         Set_No_Ctrl_Actions (Init_Stmt);
 
-         if Present (Adj_Call) then
-            Append_To (Blk_Stmts, Adj_Call);
+         if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then
+            Append_To (Blk_Stmts,
+              Make_Tag_Assignment_From_Type
+                (Loc, New_Copy_Tree (Comp), Underlying_Type (Comp_Typ)));
          end if;
       end if;
 
@@ -8796,7 +8418,7 @@ package body Exp_Aggr is
               Build_Runtime_Call (Loc, RE_Abort_Undefer));
          end if;
       end if;
-   end Initialize_Simple_Component;
+   end Initialize_Component;
 
    ----------------------------------------
    -- Is_Build_In_Place_Aggregate_Return --
@@ -9522,304 +9144,6 @@ package body Exp_Aggr is
       end if;
    end Must_Slide;
 
-   ---------------------------------
-   -- Process_Transient_Component --
-   ---------------------------------
-
-   procedure Process_Transient_Component
-     (Loc        : Source_Ptr;
-      Comp_Typ   : Entity_Id;
-      Init_Expr  : Node_Id;
-      Fin_Call   : out Node_Id;
-      Hook_Clear : out Node_Id;
-      Aggr       : Node_Id := Empty;
-      Stmts      : List_Id := No_List)
-   is
-      procedure Add_Item (Item : Node_Id);
-      --  Insert arbitrary node Item into the tree depending on the values of
-      --  Aggr and Stmts.
-
-      --------------
-      -- Add_Item --
-      --------------
-
-      procedure Add_Item (Item : Node_Id) is
-      begin
-         if Present (Aggr) then
-            Insert_Action (Aggr, Item);
-         else
-            pragma Assert (Present (Stmts));
-            Append_To (Stmts, Item);
-         end if;
-      end Add_Item;
-
-      --  Local variables
-
-      Hook_Assign : Node_Id;
-      Hook_Decl   : Node_Id;
-      Ptr_Decl    : Node_Id;
-      Res_Decl    : Node_Id;
-      Res_Id      : Entity_Id;
-      Res_Typ     : Entity_Id;
-      Copy_Init_Expr : constant Node_Id := New_Copy_Tree (Init_Expr);
-
-   --  Start of processing for Process_Transient_Component
-
-   begin
-      --  Add the access type, which provides a reference to the function
-      --  result. Generate:
-
-      --    type Res_Typ is access all Comp_Typ;
-
-      Res_Typ := Make_Temporary (Loc, 'A');
-      Mutate_Ekind (Res_Typ, E_General_Access_Type);
-      Set_Directly_Designated_Type (Res_Typ, Comp_Typ);
-
-      Add_Item
-        (Make_Full_Type_Declaration (Loc,
-           Defining_Identifier => Res_Typ,
-           Type_Definition     =>
-             Make_Access_To_Object_Definition (Loc,
-               All_Present        => True,
-               Subtype_Indication => New_Occurrence_Of (Comp_Typ, Loc))));
-
-      --  Add the temporary which captures the result of the function call.
-      --  Generate:
-
-      --    Res : constant Res_Typ := Init_Expr'Reference;
-
-      --  Note that this temporary is effectively a transient object because
-      --  its lifetime is bounded by the current array or record component.
-
-      Res_Id := Make_Temporary (Loc, 'R');
-      Mutate_Ekind (Res_Id, E_Constant);
-      Set_Etype (Res_Id, Res_Typ);
-
-      --  Mark the transient object as successfully processed to avoid double
-      --  finalization.
-
-      Set_Is_Finalized_Transient (Res_Id);
-
-      --  Signal the general finalization machinery that this transient object
-      --  should not be considered for finalization actions because its cleanup
-      --  will be performed by Process_Transient_Component_Completion.
-
-      Set_Is_Ignored_Transient (Res_Id);
-
-      Res_Decl :=
-        Make_Object_Declaration (Loc,
-          Defining_Identifier => Res_Id,
-          Constant_Present    => True,
-          Object_Definition   => New_Occurrence_Of (Res_Typ, Loc),
-          Expression          =>
-            Make_Reference (Loc, Copy_Init_Expr));
-
-      --  In some cases, like iterated component, the Init_Expr may have been
-      --  analyzed in a context where all the Etype fields are not correct yet
-      --  and a later call to Analyze is expected to set them.
-      --  Resetting the Analyzed flag ensures this later call doesn't skip this
-      --  node.
-
-      Reset_Analyzed_Flags (Copy_Init_Expr);
-
-      Add_Item (Res_Decl);
-
-      --  Construct all pieces necessary to hook and finalize the transient
-      --  result.
-
-      Build_Transient_Object_Statements
-        (Obj_Decl    => Res_Decl,
-         Fin_Call    => Fin_Call,
-         Hook_Assign => Hook_Assign,
-         Hook_Clear  => Hook_Clear,
-         Hook_Decl   => Hook_Decl,
-         Ptr_Decl    => Ptr_Decl);
-
-      --  Add the access type which provides a reference to the transient
-      --  result. Generate:
-
-      --    type Ptr_Typ is access all Comp_Typ;
-
-      Add_Item (Ptr_Decl);
-
-      --  Add the temporary which acts as a hook to the transient result.
-      --  Generate:
-
-      --    Hook : Ptr_Typ := null;
-
-      Add_Item (Hook_Decl);
-
-      --  Attach the transient result to the hook. Generate:
-
-      --    Hook := Ptr_Typ (Res);
-
-      Add_Item (Hook_Assign);
-
-      --  The original initialization expression now references the value of
-      --  the temporary function result. Generate:
-
-      --    Res.all
-
-      Rewrite (Init_Expr,
-        Make_Explicit_Dereference (Loc,
-          Prefix => New_Occurrence_Of (Res_Id, Loc)));
-   end Process_Transient_Component;
-
-   --------------------------------------------
-   -- Process_Transient_Component_Completion --
-   --------------------------------------------
-
-   procedure Process_Transient_Component_Completion
-     (Loc        : Source_Ptr;
-      Aggr       : Node_Id;
-      Fin_Call   : Node_Id;
-      Hook_Clear : Node_Id;
-      Stmts      : List_Id)
-   is
-      Exceptions_OK : constant Boolean :=
-                        not Restriction_Active (No_Exception_Propagation);
-
-   begin
-      pragma Assert (Present (Hook_Clear));
-
-      --  Generate the following code if exception propagation is allowed:
-
-      --    declare
-      --       Abort : constant Boolean := Triggered_By_Abort;
-      --         <or>
-      --       Abort : constant Boolean := False;  --  no abort
-
-      --       E      : Exception_Occurrence;
-      --       Raised : Boolean := False;
-
-      --    begin
-      --       [Abort_Defer;]
-
-      --       begin
-      --          Hook := null;
-      --          [Deep_]Finalize (Res.all);
-
-      --       exception
-      --          when others =>
-      --             if not Raised then
-      --                Raised := True;
-      --                Save_Occurrence (E,
-      --                  Get_Curent_Excep.all.all);
-      --             end if;
-      --       end;
-
-      --       [Abort_Undefer;]
-
-      --       if Raised and then not Abort then
-      --          Raise_From_Controlled_Operation (E);
-      --       end if;
-      --    end;
-
-      if Exceptions_OK then
-         Abort_And_Exception : declare
-            Blk_Decls : constant List_Id := New_List;
-            Blk_Stmts : constant List_Id := New_List;
-            Fin_Stmts : constant List_Id := New_List;
-
-            Fin_Data : Finalization_Exception_Data;
-
-         begin
-            --  Create the declarations of the two flags and the exception
-            --  occurrence.
-
-            Build_Object_Declarations (Fin_Data, Blk_Decls, Loc);
-
-            --  Generate:
-            --    Abort_Defer;
-
-            if Abort_Allowed then
-               Append_To (Blk_Stmts,
-                 Build_Runtime_Call (Loc, RE_Abort_Defer));
-            end if;
-
-            --  Wrap the hook clear and the finalization call in order to trap
-            --  a potential exception.
-
-            Append_To (Fin_Stmts, Hook_Clear);
-
-            if Present (Fin_Call) then
-               Append_To (Fin_Stmts, Fin_Call);
-            end if;
-
-            Append_To (Blk_Stmts,
-              Make_Block_Statement (Loc,
-                Handled_Statement_Sequence =>
-                  Make_Handled_Sequence_Of_Statements (Loc,
-                    Statements         => Fin_Stmts,
-                    Exception_Handlers => New_List (
-                      Build_Exception_Handler (Fin_Data)))));
-
-            --  Generate:
-            --    Abort_Undefer;
-
-            if Abort_Allowed then
-               Append_To (Blk_Stmts,
-                 Build_Runtime_Call (Loc, RE_Abort_Undefer));
-            end if;
-
-            --  Reraise the potential exception with a proper "upgrade" to
-            --  Program_Error if needed.
-
-            Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data));
-
-            --  Wrap everything in a block
-
-            Append_To (Stmts,
-              Make_Block_Statement (Loc,
-                Declarations               => Blk_Decls,
-                Handled_Statement_Sequence =>
-                  Make_Handled_Sequence_Of_Statements (Loc,
-                    Statements => Blk_Stmts)));
-         end Abort_And_Exception;
-
-      --  Generate the following code if exception propagation is not allowed
-      --  and aborts are allowed:
-
-      --    begin
-      --       Abort_Defer;
-      --       Hook := null;
-      --       [Deep_]Finalize (Res.all);
-      --    at end
-      --       Abort_Undefer_Direct;
-      --    end;
-
-      elsif Abort_Allowed then
-         Abort_Only : declare
-            Blk_Stmts : constant List_Id := New_List;
-
-         begin
-            Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
-            Append_To (Blk_Stmts, Hook_Clear);
-
-            if Present (Fin_Call) then
-               Append_To (Blk_Stmts, Fin_Call);
-            end if;
-
-            Append_To (Stmts,
-              Build_Abort_Undefer_Block (Loc,
-                Stmts   => Blk_Stmts,
-                Context => Aggr));
-         end Abort_Only;
-
-      --  Otherwise generate:
-
-      --    Hook := null;
-      --    [Deep_]Finalize (Res.all);
-
-      else
-         Append_To (Stmts, Hook_Clear);
-
-         if Present (Fin_Call) then
-            Append_To (Stmts, Fin_Call);
-         end if;
-      end if;
-   end Process_Transient_Component_Completion;
-
    ---------------------
    -- Sort_Case_Table --
    ---------------------
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 2be6e7e021e..d8214bd6ce2 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,10 +6254,18 @@ 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;
@@ -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),
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index def027f2db6..b032336523d 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -11877,14 +11877,6 @@ package body Exp_Util is
       then
          return;
 
-      --  Nothing to do if prior expansion determined that a function call does
-      --  not require side effect removal.
-
-      elsif Nkind (Exp) = N_Function_Call
-        and then No_Side_Effect_Removal (Exp)
-      then
-         return;
-
       --  No action needed for side-effect free expressions
 
       elsif Check_Side_Effects
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index ad240a70f36..c62523d9075 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -321,9 +321,9 @@ package Gen_IL.Fields is
       No_Ctrl_Actions,
       No_Elaboration_Check,
       No_Entities_Ref_In_Spec,
+      No_Finalize_Actions,
       No_Initialization,
       No_Minimize_Eliminate,
-      No_Side_Effect_Removal,
       No_Truncation,
       Null_Excluding_Subtype,
       Null_Exclusion_Present,
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index 864b7c49198..19551fd8659 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -401,8 +401,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
    Cc (N_Function_Call, N_Subprogram_Call,
        (Sy (Name, Node_Id, Default_Empty),
         Sy (Parameter_Associations, List_Id, Default_No_List),
-        Sm (Is_Expanded_Build_In_Place_Call, Flag),
-        Sm (No_Side_Effect_Removal, Flag)));
+        Sm (Is_Expanded_Build_In_Place_Call, Flag)));
 
    Cc (N_Procedure_Call_Statement, N_Subprogram_Call,
        (Sy (Name, Node_Id, Default_Empty),
@@ -970,6 +969,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
         Sm (Is_Elaboration_Code, Flag),
         Sm (Is_SPARK_Mode_On_Node, Flag),
         Sm (No_Ctrl_Actions, Flag),
+        Sm (No_Finalize_Actions, Flag),
         Sm (Suppress_Assignment_Checks, Flag)));
 
    Cc (N_Asynchronous_Select, N_Statement_Other_Than_Procedure_Call,
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index cc3e018c919..abc0e5dbb9d 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -11279,7 +11279,10 @@ package body Sem_Prag is
 
          --  Warn that suppress of Elaboration_Check has no effect in SPARK
 
-         if C = Elaboration_Check and then SPARK_Mode = On then
+         if C = Elaboration_Check
+           and then Suppress_Case
+           and then SPARK_Mode = On
+         then
             Error_Pragma_Arg
               ("Suppress of Elaboration_Check ignored in SPARK??",
                "\elaboration checking rules are statically enforced "
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 0f698cd68ee..b565221f730 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -2067,12 +2067,14 @@ package Sinfo is
    --    is undefined and should not be read).
 
    --  No_Ctrl_Actions
-   --    Present in N_Assignment_Statement to indicate that no Finalize nor
-   --    Adjust should take place on this assignment even though the RHS is
-   --    controlled. Also indicates that the primitive _assign should not be
-   --    used for a tagged assignment. This is used in init procs and aggregate
-   --    expansions where the generated assignments are initializations, not
-   --    real assignments.
+   --    Present in N_Assignment_Statement to indicate that neither Finalize
+   --    nor Adjust should take place on this assignment even though the LHS
+   --    and RHS are controlled. Also to indicate that the primitive _assign
+   --    should not be used for a tagged assignment. This flag is used in init
+   --    proc and aggregate expansion where the generated assignments are
+   --    initializations, not real assignments. Note that it also suppresses
+   --    the creation of transient scopes around the N_Assignment_Statement,
+   --    in other words it disables all controlled actions for the assignment.
 
    --  No_Elaboration_Check
    --    NOTE: this flag is relevant only for the legacy ABE mechanism and
@@ -2092,6 +2094,15 @@ package Sinfo is
    --    to generate the proper message (see Sem_Util.Check_Unused_Withs for
    --    full details).
 
+   --  No_Finalize_Actions
+   --    Present in N_Assignment_Statement to indicate that no Finalize should
+   --    take place on this assignment even though the LHS is controlled. Also
+   --    to indicate that the primitive _assign should not be used for a tagged
+   --    assignment. This flag is only used in aggregates expansion where the
+   --    generated assignments are initializations, not real assignments. Note
+   --    that, unlike the No_Ctrl_Actions flag, it does *not* suppress the
+   --    creation of transient scopes around the N_Assignment_Statement.
+
    --  No_Initialization
    --    Present in N_Object_Declaration and N_Allocator to indicate that the
    --    object must not be initialized (by Initialize or call to an init
@@ -2106,12 +2117,6 @@ package Sinfo is
    --    It is used to indicate that processing for extended overflow checking
    --    modes is not required (this is used to prevent infinite recursion).
 
-   --  No_Side_Effect_Removal
-   --    Present in N_Function_Call nodes. Set when a function call does not
-   --    require side effect removal. This attribute suppresses the generation
-   --    of a temporary to capture the result of the function which eventually
-   --    replaces the function call.
-
    --  No_Truncation
    --    Present in N_Unchecked_Type_Conversion node. This flag has an effect
    --    only if the RM_Size of the source is greater than the RM_Size of the
@@ -4934,6 +4939,7 @@ package Sinfo is
       --  Forwards_OK
       --  Backwards_OK
       --  No_Ctrl_Actions
+      --  No_Finalize_Actions
       --  Has_Target_Names
       --  Is_Elaboration_Code
       --  Componentwise_Assignment
@@ -5560,7 +5566,6 @@ package Sinfo is
       --  Is_Elaboration_Warnings_OK_Node
       --  No_Elaboration_Check
       --  Is_Expanded_Build_In_Place_Call
-      --  No_Side_Effect_Removal
       --  Is_Known_Guaranteed_ABE
       --  plus fields for expression
 
diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb
index 2a8fc364b05..a8b04370fd9 100644
--- a/gcc/ada/tbuild.adb
+++ b/gcc/ada/tbuild.adb
@@ -525,6 +525,38 @@ package body Tbuild is
       return Make_String_Literal (Sloc, Strval => End_String);
    end Make_String_Literal;
 
+   -------------------------
+   -- Make_Suppress_Block --
+   -------------------------
+
+   --  Generates the following expansion:
+
+   --    declare
+   --       pragma Suppress (<check>);
+   --    begin
+   --       <stmts>
+   --    end;
+
+   function Make_Suppress_Block
+     (Loc   : Source_Ptr;
+      Check : Name_Id;
+      Stmts : List_Id) return Node_Id
+   is
+   begin
+      return
+        Make_Block_Statement (Loc,
+          Declarations => New_List (
+            Make_Pragma (Loc,
+              Chars => Name_Suppress,
+              Pragma_Argument_Associations => New_List (
+                Make_Pragma_Argument_Association (Loc,
+                  Expression => Make_Identifier (Loc, Check))))),
+
+          Handled_Statement_Sequence =>
+            Make_Handled_Sequence_Of_Statements (Loc,
+              Statements => Stmts));
+   end Make_Suppress_Block;
+
    --------------------
    -- Make_Temporary --
    --------------------
@@ -548,7 +580,7 @@ package body Tbuild is
    --  Generates the following expansion:
 
    --    declare
-   --       pragma Suppress (<check>);
+   --       pragma Unsuppress (<check>);
    --    begin
    --       <stmts>
    --    end;
@@ -563,7 +595,7 @@ package body Tbuild is
         Make_Block_Statement (Loc,
           Declarations => New_List (
             Make_Pragma (Loc,
-              Chars => Name_Suppress,
+              Chars => Name_Unsuppress,
               Pragma_Argument_Associations => New_List (
                 Make_Pragma_Argument_Association (Loc,
                   Expression => Make_Identifier (Loc, Check))))),
diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads
index 1b42fbd89e3..bb2c70c1095 100644
--- a/gcc/ada/tbuild.ads
+++ b/gcc/ada/tbuild.ads
@@ -187,6 +187,13 @@ package Tbuild is
    --  A convenient form of Make_String_Literal, where the string value is
    --  given as a normal string instead of a String_Id value.
 
+   function Make_Suppress_Block
+     (Loc   : Source_Ptr;
+      Check : Name_Id;
+      Stmts : List_Id) return Node_Id;
+   --  Build a block with a pragma Suppress on Check. Stmts is the statements
+   --  list that needs protection against the check activation.
+
    function Make_Temporary
      (Loc          : Source_Ptr;
       Id           : Character;
@@ -207,8 +214,8 @@ package Tbuild is
      (Loc   : Source_Ptr;
       Check : Name_Id;
       Stmts : List_Id) return Node_Id;
-   --  Build a block with a pragma Suppress on 'Check'. Stmts is the statements
-   --  list that needs protection against the check
+   --  Build a block with a pragma Unsuppress on Check. Stmts is the statements
+   --  list that needs protection against the check suppression.
 
    function New_Constraint_Error (Loc : Source_Ptr) return Node_Id;
    --  This function builds a tree corresponding to the Ada statement
-- 
2.40.0


^ permalink raw reply	[flat|nested] only message in thread

only message in thread, other threads:[~2023-06-13  7:38 UTC | newest]

Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-06-13  7:38 [COMMITTED] ada: Streamline expansion of controlled actions for aggregates Marc Poulhiès

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).