[multiple changes]

2014-07-30  Bob Duff  <duff@adacore.com>

	* exp_ch6.adb (Add_Task_Actuals_To_Build_In_Place_Call): New
	parameter Chain to be used in the allocator case.
	(Make_Build_In_Place_Call_In_Allocator): If the allocated object
	has tasks, wrap the code in a block that will activate them,
	including the usual finalization code to kill them off in case
	of exception or abort.

2014-07-30  Robert Dewar  <dewar@adacore.com>

	* treepr.adb, treepr.ads; Reorganize documentation for new pp routines
	Remove renamings (don't work for gdb).
	(par): New synonym for p (avoid gdb ambiguities).
	* inline.adb, sem_ch6.adb, sem_ch13.adb: Minor reformatting.

From-SVN: r213249

gcc/ada/ChangeLog

 2014-07-30  Bob Duff  <duff@adacore.com>
 
+	* exp_ch6.adb (Add_Task_Actuals_To_Build_In_Place_Call): New
+	parameter Chain to be used in the allocator case.
+	(Make_Build_In_Place_Call_In_Allocator): If the allocated object
+	has tasks, wrap the code in a block that will activate them,
+	including the usual finalization code to kill them off in case
+	of exception or abort.
+
+2014-07-30  Robert Dewar  <dewar@adacore.com>
+
+	* treepr.adb, treepr.ads; Reorganize documentation for new pp routines
+	Remove renamings (don't work for gdb).
+	(par): New synonym for p (avoid gdb ambiguities).
+	* inline.adb, sem_ch6.adb, sem_ch13.adb: Minor reformatting.
+
+2014-07-30  Bob Duff  <duff@adacore.com>
+
 	* exp_ch9.ads, sem_prag.adb, exp_ch4.adb, sem_ch13.adb: Minor comment
 	fixes.
 	* treepr.ads, treepr.adb (ppp): Make this debugging routine

gcc/ada/exp_ch6.adb

@@ -125,7 +125,8 @@ package body Exp_Ch6 is
    procedure Add_Task_Actuals_To_Build_In_Place_Call
      (Function_Call : Node_Id;
       Function_Id   : Entity_Id;
-      Master_Actual : Node_Id);
+      Master_Actual : Node_Id;
+      Chain         : Node_Id := Empty);
    --  Ada 2005 (AI-318-02): For a build-in-place call, if the result type
    --  contains tasks, add two actual parameters: the master, and a pointer to
    --  the caller's activation chain. Master_Actual is the actual parameter
@@ -133,9 +134,11 @@ package body Exp_Ch6 is
    --  master (_master). The two exceptions are: If the function call is the
    --  initialization expression for an allocator, we pass the master of the
    --  access type. If the function call is the initialization expression for a
-   --  return object, we pass along the master passed in by the caller. The
-   --  activation chain to pass is always the local one. Note: Master_Actual
-   --  can be Empty, but only if there are no tasks.
+   --  return object, we pass along the master passed in by the caller. In most
+   --  contexts, the activation chain to pass is the local one, which is
+   --  indicated by No (Chain). However, in an allocator, the caller passes in
+   --  the activation Chain. Note: Master_Actual can be Empty, but only if
+   --  there are no tasks.
 
    procedure Check_Overriding_Operation (Subp : Entity_Id);
    --  Subp is a dispatching operation. Check whether it may override an
@@ -506,7 +509,8 @@ package body Exp_Ch6 is
    procedure Add_Task_Actuals_To_Build_In_Place_Call
      (Function_Call : Node_Id;
       Function_Id   : Entity_Id;
-      Master_Actual : Node_Id)
+      Master_Actual : Node_Id;
+      Chain         : Node_Id := Empty)
    is
       Loc           : constant Source_Ptr := Sloc (Function_Call);
       Result_Subt   : constant Entity_Id :=
@@ -554,10 +558,20 @@ package body Exp_Ch6 is
 
       --  Create the actual which is a pointer to the current activation chain
 
-      Chain_Actual :=
-        Make_Attribute_Reference (Loc,
-          Prefix         => Make_Identifier (Loc, Name_uChain),
-          Attribute_Name => Name_Unrestricted_Access);
+      if No (Chain) then
+         Chain_Actual :=
+           Make_Attribute_Reference (Loc,
+             Prefix         => Make_Identifier (Loc, Name_uChain),
+             Attribute_Name => Name_Unrestricted_Access);
+
+      --  Allocator case; make a reference to the Chain passed in by the caller
+
+      else
+         Chain_Actual :=
+           Make_Attribute_Reference (Loc,
+             Prefix         => New_Occurrence_Of (Chain, Loc),
+             Attribute_Name => Name_Unrestricted_Access);
+      end if;
 
       Analyze_And_Resolve (Chain_Actual, Etype (Chain_Formal));
 
@@ -8499,10 +8513,16 @@ package body Exp_Ch6 is
       Acc_Type          : constant Entity_Id := Etype (Allocator);
       Loc               : Source_Ptr;
       Func_Call         : Node_Id := Function_Call;
+      Ref_Func_Call     : Node_Id;
       Function_Id       : Entity_Id;
       Result_Subt       : Entity_Id;
       New_Allocator     : Node_Id;
-      Return_Obj_Access : Entity_Id;
+      Return_Obj_Access : Entity_Id; -- temp for function result
+      Temp_Init         : Node_Id; -- initial value of Return_Obj_Access
+      Alloc_Form        : BIP_Allocation_Form;
+      Pool              : Node_Id; -- nonnull if Alloc_Form = User_Storage_Pool
+      Return_Obj_Actual : Node_Id; -- the temp.all, in caller-allocates case
+      Chain             : Entity_Id; -- activation chain, in case of tasks
 
    begin
       --  Step past qualification or unchecked conversion (the latter can occur
@@ -8541,14 +8561,16 @@ package body Exp_Ch6 is
 
       Result_Subt := Available_View (Etype (Function_Id));
 
-      --  Check whether return type includes tasks. This may not have been done
-      --  previously, if the type was a limited view.
+      --  Create a temp for the function result. In the caller-allocates case,
+      --  this will be initialized to the result of a new uninitialized
+      --  allocator. Note: we do not use Allocator as the Related_Node of
+      --  Return_Obj_Access in call to Make_Temporary below as this would
+      --  create a sort of infinite "recursion".
 
-      if Has_Task (Result_Subt) then
-         Build_Activation_Chain_Entity (Allocator);
-      end if;
+      Return_Obj_Access := Make_Temporary (Loc, 'R');
+      Set_Etype (Return_Obj_Access, Acc_Type);
 
-      --  When the result subtype is constrained, the return object must be
+      --  When the result subtype is constrained, the return object is
       --  allocated on the caller side, and access to it is passed to the
       --  function.
 
@@ -8580,57 +8602,29 @@ package body Exp_Ch6 is
 
          Rewrite (Allocator, New_Allocator);
 
-         --  Create a new access object and initialize it to the result of the
-         --  new uninitialized allocator. Note: we do not use Allocator as the
-         --  Related_Node of Return_Obj_Access in call to Make_Temporary below
-         --  as this would create a sort of infinite "recursion".
+         --  Initial value of the temp is the result of the uninitialized
+         --  allocator
 
-         Return_Obj_Access := Make_Temporary (Loc, 'R');
-         Set_Etype (Return_Obj_Access, Acc_Type);
+         Temp_Init := Relocate_Node (Allocator);
 
-         Insert_Action (Allocator,
-           Make_Object_Declaration (Loc,
-             Defining_Identifier => Return_Obj_Access,
-             Object_Definition   => New_Occurrence_Of (Acc_Type, Loc),
-             Expression          => Relocate_Node (Allocator)));
+         --  Indicate that caller allocates, and pass in the return object
 
-         --  When the function has a controlling result, an allocation-form
-         --  parameter must be passed indicating that the caller is allocating
-         --  the result object. This is needed because such a function can be
-         --  called as a dispatching operation and must be treated similarly
-         --  to functions with unconstrained result subtypes.
-
-         Add_Unconstrained_Actuals_To_Build_In_Place_Call
-           (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
-
-         Add_Finalization_Master_Actual_To_Build_In_Place_Call
-           (Func_Call, Function_Id, Acc_Type);
-
-         Add_Task_Actuals_To_Build_In_Place_Call
-           (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type));
-
-         --  Add an implicit actual to the function call that provides access
-         --  to the allocated object. An unchecked conversion to the (specific)
-         --  result subtype of the function is inserted to handle cases where
-         --  the access type of the allocator has a class-wide designated type.
-
-         Add_Access_Actual_To_Build_In_Place_Call
-           (Func_Call,
-            Function_Id,
-            Make_Unchecked_Type_Conversion (Loc,
-              Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
-              Expression   =>
-                Make_Explicit_Dereference (Loc,
-                  Prefix => New_Occurrence_Of (Return_Obj_Access, Loc))));
+         Alloc_Form := Caller_Allocation;
+         Pool := Make_Null (No_Location);
+         Return_Obj_Actual :=
+           Make_Unchecked_Type_Conversion (Loc,
+             Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
+             Expression   =>
+               Make_Explicit_Dereference (Loc,
+                 Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)));
 
       --  When the result subtype is unconstrained, the function itself must
       --  perform the allocation of the return object, so we pass parameters
-      --  indicating that. We don't yet handle the case where the allocation
-      --  must be done in a user-defined storage pool, which will require
-      --  passing another actual or two to provide allocation/deallocation
-      --  operations. ???
+      --  indicating that.
 
       else
+         Temp_Init := Empty;
+
          --  Case of a user-defined storage pool. Pass an allocation parameter
          --  indicating that the function should allocate its result in the
          --  pool, and pass the pool. Use 'Unrestricted_Access because the
@@ -8639,36 +8633,103 @@ package body Exp_Ch6 is
          if VM_Target = No_VM
            and then Present (Associated_Storage_Pool (Acc_Type))
          then
-            Add_Unconstrained_Actuals_To_Build_In_Place_Call
-              (Func_Call, Function_Id, Alloc_Form => User_Storage_Pool,
-               Pool_Actual =>
-                 Make_Attribute_Reference (Loc,
-                   Prefix         =>
-                     New_Occurrence_Of
-                       (Associated_Storage_Pool (Acc_Type), Loc),
-                   Attribute_Name => Name_Unrestricted_Access));
+            Alloc_Form := User_Storage_Pool;
+            Pool :=
+              Make_Attribute_Reference (Loc,
+                Prefix         =>
+                  New_Occurrence_Of
+                    (Associated_Storage_Pool (Acc_Type), Loc),
+                Attribute_Name => Name_Unrestricted_Access);
 
          --  No user-defined pool; pass an allocation parameter indicating that
          --  the function should allocate its result on the heap.
 
          else
-            Add_Unconstrained_Actuals_To_Build_In_Place_Call
-              (Func_Call, Function_Id, Alloc_Form => Global_Heap);
+            Alloc_Form := Global_Heap;
+            Pool := Make_Null (No_Location);
          end if;
 
-         Add_Finalization_Master_Actual_To_Build_In_Place_Call
-           (Func_Call, Function_Id, Acc_Type);
-
-         Add_Task_Actuals_To_Build_In_Place_Call
-           (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type));
-
          --  The caller does not provide the return object in this case, so we
          --  have to pass null for the object access actual.
 
-         Add_Access_Actual_To_Build_In_Place_Call
-           (Func_Call, Function_Id, Return_Object => Empty);
+         Return_Obj_Actual := Empty;
       end if;
 
+      --  Declare the temp object
+
+      Insert_Action (Allocator,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => Return_Obj_Access,
+          Object_Definition   => New_Occurrence_Of (Acc_Type, Loc),
+          Expression          => Temp_Init));
+
+      Ref_Func_Call := Make_Reference (Loc, Func_Call);
+
+      --  Ada 2005 (AI-251): If the type of the allocator is an interface
+      --  then generate an implicit conversion to force displacement of the
+      --  "this" pointer.
+
+      if Is_Interface (Designated_Type (Acc_Type)) then
+         Rewrite
+           (Ref_Func_Call,
+            OK_Convert_To (Acc_Type, Ref_Func_Call));
+      end if;
+
+      declare
+         Assign : constant Node_Id :=
+           Make_Assignment_Statement (Loc,
+             Name       => New_Occurrence_Of (Return_Obj_Access, Loc),
+             Expression => Ref_Func_Call);
+         --  Assign the result of the function call into the temp. In the
+         --  caller-allocates case, this is overwriting the temp with its
+         --  initial value, which has no effect. In the callee-allocates case,
+         --  this is setting the temp to point to the object allocated by the
+         --  callee.
+
+         Actions : List_Id;
+         --  Actions to be inserted. If there are no tasks, this is just the
+         --  assignment statement. If the allocated object has tasks, we need
+         --  to wrap the assignment in a block that activates them. The
+         --  activation chain of that block must be passed to the function,
+         --  rather than some outer chain.
+      begin
+         if Has_Task (Result_Subt) then
+            Actions := New_List;
+            Build_Task_Allocate_Block_With_Init_Stmts
+              (Actions, Allocator, Init_Stmts => New_List (Assign));
+            Chain := Activation_Chain_Entity (Last (Actions));
+         else
+            Actions := New_List (Assign);
+            Chain   := Empty;
+         end if;
+
+         Insert_Actions (Allocator, Actions);
+      end;
+
+      --  When the function has a controlling result, an allocation-form
+      --  parameter must be passed indicating that the caller is allocating
+      --  the result object. This is needed because such a function can be
+      --  called as a dispatching operation and must be treated similarly
+      --  to functions with unconstrained result subtypes.
+
+      Add_Unconstrained_Actuals_To_Build_In_Place_Call
+        (Func_Call, Function_Id, Alloc_Form, Pool_Actual => Pool);
+
+      Add_Finalization_Master_Actual_To_Build_In_Place_Call
+        (Func_Call, Function_Id, Acc_Type);
+
+      Add_Task_Actuals_To_Build_In_Place_Call
+        (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type),
+         Chain => Chain);
+
+      --  Add an implicit actual to the function call that provides access
+      --  to the allocated object. An unchecked conversion to the (specific)
+      --  result subtype of the function is inserted to handle cases where
+      --  the access type of the allocator has a class-wide designated type.
+
+      Add_Access_Actual_To_Build_In_Place_Call
+        (Func_Call, Function_Id, Return_Obj_Actual);
+
       --  If the build-in-place function call returns a controlled object,
       --  the finalization master will require a reference to routine
       --  Finalize_Address of the designated type. Setting this attribute
@@ -8696,19 +8757,9 @@ package body Exp_Ch6 is
          end if;
       end if;
 
-      --  Finally, replace the allocator node with a reference to the result
-      --  of the function call itself (which will effectively be an access
-      --  to the object created by the allocator).
+      --  Finally, replace the allocator node with a reference to the temp
 
-      Rewrite (Allocator, Make_Reference (Loc, Relocate_Node (Function_Call)));
-
-      --  Ada 2005 (AI-251): If the type of the allocator is an interface then
-      --  generate an implicit conversion to force displacement of the "this"
-      --  pointer.
-
-      if Is_Interface (Designated_Type (Acc_Type)) then
-         Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator)));
-      end if;
+      Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc));
 
       Analyze_And_Resolve (Allocator, Acc_Type);
    end Make_Build_In_Place_Call_In_Allocator;

gcc/ada/inline.adb

@@ -1490,12 +1490,11 @@ package body Inline is
 
       function Has_Some_Contract (Id : Entity_Id) return Boolean is
          Items : constant Node_Id := Contract (Id);
-
       begin
          return Present (Items)
-           and then (Present (Pre_Post_Conditions (Items))
-                      or else Present (Contract_Test_Cases (Items))
-                      or else Present (Classifications (Items)));
+           and then (Present (Pre_Post_Conditions (Items)) or else
+                     Present (Contract_Test_Cases (Items)) or else
+                     Present (Classifications     (Items)));
       end Has_Some_Contract;
 
       --------------------------
@@ -1559,6 +1558,10 @@ package body Inline is
          Id := Body_Id;
       end if;
 
+      --  General note. The following comments clearly say what cannot be
+      --  inlined, but they do not give any clue on the motivation for the
+      --  exclusion. It would be good to document the motivations ???
+
       --  Do not inline unit-level subprograms
 
       if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
@@ -1588,6 +1591,8 @@ package body Inline is
       then
          return False;
 
+      --  Do not inline generic subprogram instances
+
       elsif Is_Generic_Instance (Spec_Id) then
          return False;
 

gcc/ada/sem_ch13.adb

@@ -2013,7 +2013,6 @@ package body Sem_Ch13 is
 
                      declare
                         Discard : Entity_Id;
-                        pragma Warnings (Off, Discard);
                      begin
                         if Restricted_Profile then
                            Discard := RTE (RE_Activate_Restricted_Tasks);

gcc/ada/sem_ch6.adb

@@ -2169,7 +2169,7 @@ package body Sem_Ch6 is
 
       function Body_Has_Contract return Boolean;
       --  Check whether unanalyzed body has an aspect or pragma that may
-      --  generate a SPARK contrac.
+      --  generate a SPARK contract.
 
       procedure Check_Anonymous_Return;
       --  Ada 2005: if a function returns an access type that denotes a task,
@@ -2363,13 +2363,13 @@ package body Sem_Ch6 is
             while Present (A_Spec) loop
                A := Get_Aspect_Id (Chars (Identifier (A_Spec)));
 
-               if A = Aspect_Contract_Cases
-                 or else A = Aspect_Depends
-                 or else A = Aspect_Global
-                 or else A = Aspect_Pre
-                 or else A = Aspect_Precondition
-                 or else A = Aspect_Post
-                 or else A = Aspect_Postcondition
+               if A = Aspect_Contract_Cases or else
+                  A = Aspect_Depends        or else
+                  A = Aspect_Global         or else
+                  A = Aspect_Pre            or else
+                  A = Aspect_Precondition   or else
+                  A = Aspect_Post           or else
+                  A = Aspect_Postcondition
                then
                   return True;
                end if;
@@ -2378,7 +2378,7 @@ package body Sem_Ch6 is
             end loop;
          end if;
 
-         --  Check for pragmas that may generate a contract.
+         --  Check for pragmas that may generate a contract
 
          if Present (Decls) then
             Decl := First (Decls);
@@ -2386,13 +2386,13 @@ package body Sem_Ch6 is
                if Nkind (Decl) = N_Pragma then
                   P_Id := Get_Pragma_Id (Pragma_Name (Decl));
 
-                  if P_Id = Pragma_Contract_Cases
-                    or else P_Id = Pragma_Depends
-                    or else P_Id = Pragma_Global
-                    or else P_Id = Pragma_Pre
-                    or else P_Id = Pragma_Precondition
-                    or else P_Id = Pragma_Post
-                    or else P_Id = Pragma_Postcondition
+                  if P_Id = Pragma_Contract_Cases or else
+                     P_Id = Pragma_Depends        or else
+                     P_Id = Pragma_Global         or else
+                     P_Id = Pragma_Pre            or else
+                     P_Id = Pragma_Precondition   or else
+                     P_Id = Pragma_Post           or else
+                     P_Id = Pragma_Postcondition
                   then
                      return True;
                   end if;

gcc/ada/treepr.adb

@@ -236,6 +236,18 @@ package body Treepr is
       end case;
    end p;
 
+   ---------
+   -- par --
+   ---------
+
+   function par (N : Union_Id) return Node_Or_Entity_Id renames p;
+
+   --------
+   -- pe --
+   --------
+
+   procedure pe (N : Union_Id) renames pn;
+
    --------
    -- pl --
    --------
@@ -314,6 +326,18 @@ package body Treepr is
       end case;
    end pn;
 
+   --------
+   -- pp --
+   --------
+
+   procedure pp (N : Union_Id) renames pn;
+
+   ---------
+   -- ppp --
+   ---------
+
+   procedure ppp (N : Union_Id) renames pt;
+
    ----------------
    -- Print_Char --
    ----------------

gcc/ada/treepr.ads

@@ -60,22 +60,33 @@ package Treepr is
    --  Prints the subtree consisting of the given element list and all its
    --  referenced descendants.
 
-   --  The following debugging procedures are intended to be called from gdb
+   --  The following debugging procedures are intended to be called from gdb.
+   --  Note that in several cases there are synonyms which represent historical
+   --  development, and we keep them because some people are used to them!
 
-   function p (N : Union_Id) return Node_Or_Entity_Id;
+   function p   (N : Union_Id) return Node_Or_Entity_Id;
+   function par (N : Union_Id) return Node_Or_Entity_Id;
    pragma Export (Ada, p);
-   --  Returns parent of a list or node (depending on the value of N). If N
+   pragma Export (Ada, par);
+   --  Return parent of a list or node (depending on the value of N). If N
    --  is neither a list nor a node id, then prints a message to that effect
    --  and returns Empty.
 
    procedure pn (N : Union_Id);
-   --  Prints a node, node list, uint, or anything else that falls under
+   procedure pp (N : Union_Id);
+   procedure pe (N : Union_Id);
+   pragma Export (Ada, pn);
+   pragma Export (Ada, pp);
+   pragma Export (Ada, pe);
+   --  Print a node, node list, uint, or anything else that falls under
    --  the definition of Union_Id. Historically this was only for printing
    --  nodes, hence the name.
 
-   procedure pt (N : Union_Id);
+   procedure pt  (N : Union_Id);
+   procedure ppp (N : Union_Id);
    pragma Export (Ada, pt);
-   --  Same as pn, except prints subtrees. For Nodes, it is exactly the same
+   pragma Export (Ada, ppp);
+   --  Same as pn/pp, except prints subtrees. For Nodes, it is exactly the same
    --  as Print_Node_Subtree. For Elists it is the same as Print_Elist_Subtree.
    --  For Lists, it is the same as Print_Tree_List. If given anything other
    --  than a Node, List, or Elist, same effect as pn.
@@ -87,9 +98,4 @@ package Treepr is
    --  on the left and add a minus sign. This just saves some typing in the
    --  debugger.
 
-   procedure pe  (N : Union_Id) renames pt;
-   procedure pp  (N : Union_Id) renames pn;
-   procedure ppp (N : Union_Id) renames pt;
-   --  Synonyms retained for historical reasons
-
 end Treepr;