[Ada] Early finalization of ctrl func result clobbers array element

Index: sem_aggr.adb
===================================================================
--- sem_aggr.adb	(revision 237957)
+++ sem_aggr.adb	(working copy)
@@ -1821,6 +1821,25 @@ 
          end if;
 
          Step_2 : declare
+            function Empty_Range (A : Node_Id) return Boolean;
+            --  If an association covers an empty range, some warnings on the
+            --  expression of the association can be disabled.
+
+            -----------------
+            -- Empty_Range --
+            -----------------
+
+            function Empty_Range (A : Node_Id) return Boolean is
+               R : constant Node_Id := First (Choices (A));
+            begin
+               return No (Next (R))
+                 and then Nkind (R) = N_Range
+                 and then Compile_Time_Compare
+                            (Low_Bound (R), High_Bound (R), False) = GT;
+            end Empty_Range;
+
+            --  Local variables
+
             Low  : Node_Id;
             High : Node_Id;
             --  Denote the lowest and highest values in an aggregate choice
@@ -1845,23 +1864,6 @@ 
             Errors_Posted_On_Choices : Boolean := False;
             --  Keeps track of whether any choices have semantic errors
 
-            function Empty_Range (A : Node_Id) return Boolean;
-            --  If an association covers an empty range, some warnings on the
-            --  expression of the association can be disabled.
-
-            -----------------
-            -- Empty_Range --
-            -----------------
-
-            function Empty_Range (A : Node_Id) return Boolean is
-               R : constant Node_Id := First (Choices (A));
-            begin
-               return No (Next (R))
-                 and then Nkind (R) = N_Range
-                 and then Compile_Time_Compare
-                            (Low_Bound (R), High_Bound (R), False) = GT;
-            end Empty_Range;
-
          --  Start of processing for Step_2
 
          begin
@@ -3429,10 +3431,6 @@ 
       -----------------------
 
       procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is
-         Expr_Type : Entity_Id := Empty;
-         New_C     : Entity_Id := Component;
-         New_Expr  : Node_Id;
-
          function Has_Expansion_Delayed (Expr : Node_Id) return Boolean;
          --  If the expression is an aggregate (possibly qualified) then its
          --  expansion is delayed until the enclosing aggregate is expanded
@@ -3442,15 +3440,6 @@ 
          --  dynamic-sized aggregate in the code, something that gigi cannot
          --  handle.
 
-         Relocate : Boolean;
-         --  Set to True if the resolved Expr node needs to be relocated when
-         --  attached to the newly created association list. This node need not
-         --  be relocated if its parent pointer is not set. In fact in this
-         --  case Expr is the output of a New_Copy_Tree call. If Relocate is
-         --  True then we have analyzed the expression node in the original
-         --  aggregate and hence it needs to be relocated when moved over to
-         --  the new association list.
-
          ---------------------------
          -- Has_Expansion_Delayed --
          ---------------------------
@@ -3466,6 +3455,21 @@ 
                         and then Has_Expansion_Delayed (Expression (Expr)));
          end Has_Expansion_Delayed;
 
+         --  Local variables
+
+         Expr_Type : Entity_Id := Empty;
+         New_C     : Entity_Id := Component;
+         New_Expr  : Node_Id;
+
+         Relocate : Boolean;
+         --  Set to True if the resolved Expr node needs to be relocated when
+         --  attached to the newly created association list. This node need not
+         --  be relocated if its parent pointer is not set. In fact in this
+         --  case Expr is the output of a New_Copy_Tree call. If Relocate is
+         --  True then we have analyzed the expression node in the original
+         --  aggregate and hence it needs to be relocated when moved over to
+         --  the new association list.
+
       --  Start of processing for Resolve_Aggr_Expr
 
       begin
Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 237957)
+++ exp_util.adb	(working copy)
@@ -7693,16 +7693,25 @@ 
         and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
       then
          return;
-      end if;
 
       --  Cannot generate temporaries if the invocation to remove side effects
       --  was issued too early and the type of the expression is not resolved
       --  (this happens because routines Duplicate_Subexpr_XX implicitly invoke
       --  Remove_Side_Effects).
 
-      if No (Exp_Type) or else Ekind (Exp_Type) = E_Access_Attribute_Type then
+      elsif No (Exp_Type)
+        or else Ekind (Exp_Type) = E_Access_Attribute_Type
+      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
Index: sinfo.adb
===================================================================
--- sinfo.adb	(revision 237957)
+++ sinfo.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2016, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -2409,6 +2409,14 @@ 
       return Flag17 (N);
    end No_Minimize_Eliminate;
 
+   function No_Side_Effect_Removal
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Call);
+      return Flag1 (N);
+   end No_Side_Effect_Removal;
+
    function No_Truncation
       (N : Node_Id) return Boolean is
    begin
@@ -5664,6 +5672,14 @@ 
       Set_Flag17 (N, Val);
    end Set_No_Minimize_Eliminate;
 
+   procedure Set_No_Side_Effect_Removal
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Function_Call);
+      Set_Flag1 (N, Val);
+   end Set_No_Side_Effect_Removal;
+
    procedure Set_No_Truncation
       (N : Node_Id; Val : Boolean := True) is
    begin
Index: sinfo.ads
===================================================================
--- sinfo.ads	(revision 237957)
+++ sinfo.ads	(working copy)
@@ -1946,6 +1946,12 @@ 
    --    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 (Flag1-Sem)
+   --    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 (Flag17-Sem)
    --    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
@@ -5296,6 +5302,7 @@ 
       --   actual parameter part)
       --  First_Named_Actual (Node4-Sem)
       --  Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
+      --  No_Side_Effect_Removal (Flag1-Sem)
       --  Is_Expanded_Build_In_Place_Call (Flag11-Sem)
       --  Do_Tag_Check (Flag13-Sem)
       --  No_Elaboration_Check (Flag14-Sem)
@@ -9540,6 +9547,9 @@ 
    function No_Minimize_Eliminate
      (N : Node_Id) return Boolean;    -- Flag17
 
+   function No_Side_Effect_Removal
+     (N : Node_Id) return Boolean;    -- Flag1
+
    function No_Truncation
      (N : Node_Id) return Boolean;    -- Flag17
 
@@ -10581,6 +10591,9 @@ 
    procedure Set_No_Minimize_Eliminate
      (N : Node_Id; Val : Boolean := True);    -- Flag17
 
+   procedure Set_No_Side_Effect_Removal
+     (N : Node_Id; Val : Boolean := True);    -- Flag1
+
    procedure Set_No_Truncation
      (N : Node_Id; Val : Boolean := True);    -- Flag17
 
@@ -12877,6 +12890,7 @@ 
    pragma Inline (No_Entities_Ref_In_Spec);
    pragma Inline (No_Initialization);
    pragma Inline (No_Minimize_Eliminate);
+   pragma Inline (No_Side_Effect_Removal);
    pragma Inline (No_Truncation);
    pragma Inline (Non_Aliased_Prefix);
    pragma Inline (Null_Present);
@@ -13220,6 +13234,7 @@ 
    pragma Inline (Set_No_Entities_Ref_In_Spec);
    pragma Inline (Set_No_Initialization);
    pragma Inline (Set_No_Minimize_Eliminate);
+   pragma Inline (Set_No_Side_Effect_Removal);
    pragma Inline (Set_No_Truncation);
    pragma Inline (Set_Non_Aliased_Prefix);
    pragma Inline (Set_Null_Excluding_Subtype);
Index: exp_aggr.adb
===================================================================
--- exp_aggr.adb	(revision 237957)
+++ exp_aggr.adb	(working copy)
@@ -1017,19 +1017,20 @@ 
       ----------------
 
       function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is
-         L : constant List_Id := New_List;
-         A : Node_Id;
-
-         New_Indexes  : List_Id;
-         Indexed_Comp : Node_Id;
-         Expr_Q       : Node_Id;
-         Comp_Type    : Entity_Id := Empty;
-
          function Add_Loop_Actions (Lis : List_Id) return List_Id;
          --  Collect insert_actions generated in the construction of a
          --  loop, and prepend them to the sequence of assignments to
          --  complete the eventual body of the loop.
 
+         function Ctrl_Init_Expression
+           (Comp_Typ : Entity_Id;
+            Stmts    : List_Id) return Node_Id;
+         --  Perform in-place side effect removal if expression Expr denotes a
+         --  controlled function call. Return a reference to the entity which
+         --  captures the result of the call. Comp_Typ is the expected type of
+         --  the component. Stmts is the list of initialization statmenets. Any
+         --  generated code is added to Stmts.
+
          ----------------------
          -- Add_Loop_Actions --
          ----------------------
@@ -1057,6 +1058,91 @@ 
             end if;
          end Add_Loop_Actions;
 
+         --------------------------
+         -- Ctrl_Init_Expression --
+         --------------------------
+
+         function Ctrl_Init_Expression
+           (Comp_Typ : Entity_Id;
+            Stmts    : List_Id) return Node_Id
+         is
+            Init_Expr : Node_Id;
+            Obj_Id    : Entity_Id;
+            Ptr_Typ   : Entity_Id;
+
+         begin
+            Init_Expr := New_Copy_Tree (Expr);
+
+            --  Perform a preliminary analysis and resolution to determine
+            --  what the expression denotes. Note that a function call may
+            --  appear as an identifier or an indexed component.
+
+            Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
+
+            --  The initialization expression is a controlled function call.
+            --  Perform in-place removal of side effects to avoid creating a
+            --  transient scope. In the end the temporary function result is
+            --  finalized by the general finalization machinery.
+
+            if Nkind (Init_Expr) = N_Function_Call then
+
+               --  Suppress the removal of side effects by generatal analysis
+               --  because this behavior is emulated here.
+
+               Set_No_Side_Effect_Removal (Init_Expr);
+
+               --  Generate:
+               --    type Ptr_Typ is access all Comp_Typ;
+
+               Ptr_Typ := Make_Temporary (Loc, 'A');
+
+               Append_To (Stmts,
+                 Make_Full_Type_Declaration (Loc,
+                   Defining_Identifier => Ptr_Typ,
+                   Type_Definition     =>
+                     Make_Access_To_Object_Definition (Loc,
+                       All_Present        => True,
+                       Subtype_Indication =>
+                         New_Occurrence_Of (Comp_Typ, Loc))));
+
+               --  Generate:
+               --    Obj : constant Ptr_Typ := Init_Expr'Reference;
+
+               Obj_Id := Make_Temporary (Loc, 'R');
+
+               Append_To (Stmts,
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Obj_Id,
+                   Object_Definition   => New_Occurrence_Of (Ptr_Typ, Loc),
+                   Expression          => Make_Reference (Loc, Init_Expr)));
+
+               --  Generate:
+               --    Obj.all;
+
+               return
+                 Make_Explicit_Dereference (Loc,
+                   Prefix => New_Occurrence_Of (Obj_Id, Loc));
+
+            --  Otherwise the initialization expression denotes a controlled
+            --  object. There is nothing special to be done here as there is
+            --  no possible transient scope involvement.
+
+            else
+               return Init_Expr;
+            end if;
+         end Ctrl_Init_Expression;
+
+         --  Local variables
+
+         Stmts : constant List_Id := New_List;
+
+         Comp_Typ     : Entity_Id := Empty;
+         Expr_Q       : Node_Id;
+         Indexed_Comp : Node_Id;
+         New_Indexes  : List_Id;
+         Stmt         : Node_Id;
+         Stmt_Expr    : Node_Id;
+
       --  Start of processing for Gen_Assign
 
       begin
@@ -1102,8 +1188,8 @@ 
          end if;
 
          if Present (Etype (N)) and then Etype (N) /= Any_Composite then
-            Comp_Type := Component_Type (Etype (N));
-            pragma Assert (Comp_Type = Ctype); --  AI-287
+            Comp_Typ := Component_Type (Etype (N));
+            pragma Assert (Comp_Typ = Ctype); --  AI-287
 
          elsif Present (Next (First (New_Indexes))) then
 
@@ -1129,7 +1215,7 @@ 
                      if Nkind (P) = N_Aggregate
                        and then Present (Etype (P))
                      then
-                        Comp_Type := Component_Type (Etype (P));
+                        Comp_Typ := Component_Type (Etype (P));
                         exit;
 
                      else
@@ -1137,7 +1223,7 @@ 
                      end if;
                   end loop;
 
-                  pragma Assert (Comp_Type = Ctype); --  AI-287
+                  pragma Assert (Comp_Typ = Ctype); --  AI-287
                end;
             end if;
          end if;
@@ -1155,8 +1241,8 @@ 
             --  the analysis of non-array aggregates now in order to get the
             --  value of Expansion_Delayed flag for the inner aggregate ???
 
-            if Present (Comp_Type) and then not Is_Array_Type (Comp_Type) then
-               Analyze_And_Resolve (Expr_Q, Comp_Type);
+            if Present (Comp_Typ) and then not Is_Array_Type (Comp_Typ) then
+               Analyze_And_Resolve (Expr_Q, Comp_Typ);
             end if;
 
             if Is_Delayed_Aggregate (Expr_Q) then
@@ -1171,9 +1257,9 @@ 
                --  generated in the usual fashion, and sliding will take place.
 
                if Nkind (Parent (N)) = N_Assignment_Statement
-                 and then Is_Array_Type (Comp_Type)
+                 and then Is_Array_Type (Comp_Typ)
                  and then Present (Component_Associations (Expr_Q))
-                 and then Must_Slide (Comp_Type, Etype (Expr_Q))
+                 and then Must_Slide (Comp_Typ, Etype (Expr_Q))
                then
                   Set_Expansion_Delayed (Expr_Q, False);
                   Set_Analyzed (Expr_Q, False);
@@ -1201,7 +1287,7 @@ 
             if Present (Base_Init_Proc (Base_Type (Ctype)))
               or else Has_Task (Base_Type (Ctype))
             then
-               Append_List_To (L,
+               Append_List_To (Stmts,
                  Build_Initialization_Call (Loc,
                    Id_Ref            => Indexed_Comp,
                    Typ               => Ctype,
@@ -1214,28 +1300,81 @@ 
 
                if Has_Invariants (Ctype) then
                   Set_Etype (Indexed_Comp, Ctype);
-                  Append_To (L, Make_Invariant_Call (Indexed_Comp));
+                  Append_To (Stmts, Make_Invariant_Call (Indexed_Comp));
                end if;
 
             elsif Is_Access_Type (Ctype) then
-               Append_To (L,
+               Append_To (Stmts,
                  Make_Assignment_Statement (Loc,
-                   Name       => Indexed_Comp,
+                   Name       => New_Copy_Tree (Indexed_Comp),
                    Expression => Make_Null (Loc)));
             end if;
 
             if Needs_Finalization (Ctype) then
-               Append_To (L,
+               Append_To (Stmts,
                  Make_Init_Call
                    (Obj_Ref => New_Copy_Tree (Indexed_Comp),
                     Typ     => Ctype));
             end if;
 
          else
-            A :=
+            --  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.
+
+            --    Arr_Comp (1) := Ctrl_Func_Call;
+
+            --    begin                                  --  transient scope
+            --       Trans_Obj : ... := Ctrl_Func_Call;  --  transient object
+            --       Arr_Comp (1) := Trans_Obj;
+            --       Finalize (Trans_Obj);
+            --    end;
+            --    Arr_Comp (1)._tag := ...;
+            --    Adjust (Arr_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.
+            --  Note that the function result behaves as a source controlled
+            --  object and is finalized by the general finalization mechanism.
+
+            --    begin
+            --       Res : ... := Ctrl_Func_Call;
+            --       Arr_Comp (1) := Res;
+            --       Arr_Comp (1)._tag := ...;
+            --       Adjust (Arr_Comp (1));
+            --    at end
+            --       Finalize (Res);
+            --    end;
+
+            --  There is no need to perform this kind of light expansion when
+            --  the component type is limited controlled because everything is
+            --  already done in place.
+
+            if Present (Comp_Typ)
+              and then Needs_Finalization (Comp_Typ)
+              and then not Is_Limited_Type (Comp_Typ)
+              and then Nkind (Expr) /= N_Aggregate
+            then
+               Stmt_Expr := Ctrl_Init_Expression (Comp_Typ, Stmts);
+
+            --  Otherwise use the initialization expression directly
+
+            else
+               Stmt_Expr := New_Copy_Tree (Expr);
+            end if;
+
+            Stmt :=
               Make_OK_Assignment_Statement (Loc,
-                Name       => Indexed_Comp,
-                Expression => New_Copy_Tree (Expr));
+                Name       => New_Copy_Tree (Indexed_Comp),
+                Expression => Stmt_Expr);
 
             --  The target of the assignment may not have been initialized,
             --  so it is not possible to call Finalize as expected in normal
@@ -1248,7 +1387,7 @@ 
             --  actions are done manually with the proper finalization list
             --  coming from the context.
 
-            Set_No_Ctrl_Actions (A);
+            Set_No_Ctrl_Actions (Stmt);
 
             --  If this is an aggregate for an array of arrays, each
             --  subaggregate will be expanded as well, and even with
@@ -1260,33 +1399,31 @@ 
             --  that finalization takes place for each subaggregate we wrap the
             --  assignment in a block.
 
-            if Present (Comp_Type)
-              and then Needs_Finalization (Comp_Type)
-              and then Is_Array_Type (Comp_Type)
+            if Present (Comp_Typ)
+              and then Needs_Finalization (Comp_Typ)
+              and then Is_Array_Type (Comp_Typ)
               and then Present (Expr)
             then
-               A :=
+               Stmt :=
                  Make_Block_Statement (Loc,
                    Handled_Statement_Sequence =>
                      Make_Handled_Sequence_Of_Statements (Loc,
-                       Statements => New_List (A)));
+                       Statements => New_List (Stmt)));
             end if;
 
-            Append_To (L, A);
+            Append_To (Stmts, Stmt);
 
-            --  Adjust the tag if tagged (because of possible view
-            --  conversions), unless compiling for a VM where tags
-            --  are implicit.
+            --  Adjust the tag due to a possible view conversion
 
-            if Present (Comp_Type)
-              and then Is_Tagged_Type (Comp_Type)
+            if Present (Comp_Typ)
+              and then Is_Tagged_Type (Comp_Typ)
               and then Tagged_Type_Expansion
             then
                declare
-                  Full_Typ : constant Entity_Id := Underlying_Type (Comp_Type);
+                  Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
 
                begin
-                  A :=
+                  Append_To (Stmts,
                     Make_OK_Assignment_Statement (Loc,
                       Name       =>
                         Make_Selected_Component (Loc,
@@ -1299,9 +1436,7 @@ 
                         Unchecked_Convert_To (RTE (RE_Tag),
                           New_Occurrence_Of
                             (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
-                             Loc)));
-
-                  Append_To (L, A);
+                             Loc))));
                end;
             end if;
 
@@ -1316,22 +1451,22 @@ 
             --  (see comments above, concerning the creation of a block to hold
             --  inner finalization actions).
 
-            if Present (Comp_Type)
-              and then Needs_Finalization (Comp_Type)
-              and then not Is_Limited_Type (Comp_Type)
+            if Present (Comp_Typ)
+              and then Needs_Finalization (Comp_Typ)
+              and then not Is_Limited_Type (Comp_Typ)
               and then not
-                (Is_Array_Type (Comp_Type)
-                  and then Is_Controlled (Component_Type (Comp_Type))
+                (Is_Array_Type (Comp_Typ)
+                  and then Is_Controlled (Component_Type (Comp_Typ))
                   and then Nkind (Expr) = N_Aggregate)
             then
-               Append_To (L,
+               Append_To (Stmts,
                  Make_Adjust_Call
                    (Obj_Ref => New_Copy_Tree (Indexed_Comp),
-                    Typ     => Comp_Type));
+                    Typ     => Comp_Typ));
             end if;
          end if;
 
-         return Add_Loop_Actions (L);
+         return Add_Loop_Actions (Stmts);
       end Gen_Assign;
 
       --------------