OSDN Git Service

2011-12-05 Bob Duff <duff@adacore.com>
[pf3gnuchains/gcc-fork.git] / gcc / ada / exp_ch6.adb
index 23558e0..4c94604 100644 (file)
@@ -94,15 +94,18 @@ package body Exp_Ch6 is
    --  along directly to the build-in-place function. Finally, if Return_Object
    --  is empty, then pass a null literal as the actual.
 
-   procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call
+   procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call
      (Function_Call  : Node_Id;
       Function_Id    : Entity_Id;
       Alloc_Form     : BIP_Allocation_Form := Unspecified;
-      Alloc_Form_Exp : Node_Id             := Empty);
-   --  Ada 2005 (AI-318-02): Add an actual indicating the form of allocation,
-   --  if any, to be done by a build-in-place function. If Alloc_Form_Exp is
-   --  present, then use it, otherwise pass a literal corresponding to the
-   --  Alloc_Form parameter (which must not be Unspecified in that case).
+      Alloc_Form_Exp : Node_Id             := Empty;
+      Pool_Actual    : Node_Id             := Make_Null (No_Location));
+   --  Ada 2005 (AI-318-02): Add the actuals needed for a build-in-place
+   --  function call that returns a caller-unknown-size result (BIP_Alloc_Form
+   --  and BIP_Storage_Pool). If Alloc_Form_Exp is present, then use it,
+   --  otherwise pass a literal corresponding to the Alloc_Form parameter
+   --  (which must not be Unspecified in that case). Pool_Actual is the
+   --  parameter to pass to BIP_Storage_Pool.
 
    procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
      (Func_Call  : Node_Id;
@@ -251,19 +254,21 @@ package body Exp_Ch6 is
       Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address);
    end Add_Access_Actual_To_Build_In_Place_Call;
 
-   --------------------------------------------------
-   -- Add_Alloc_Form_Actual_To_Build_In_Place_Call --
-   --------------------------------------------------
+   ------------------------------------------------------
+   -- Add_Unconstrained_Actuals_To_Build_In_Place_Call --
+   ------------------------------------------------------
 
-   procedure Add_Alloc_Form_Actual_To_Build_In_Place_Call
+   procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call
      (Function_Call  : Node_Id;
       Function_Id    : Entity_Id;
       Alloc_Form     : BIP_Allocation_Form := Unspecified;
-      Alloc_Form_Exp : Node_Id             := Empty)
+      Alloc_Form_Exp : Node_Id             := Empty;
+      Pool_Actual    : Node_Id             := Make_Null (No_Location))
    is
       Loc               : constant Source_Ptr := Sloc (Function_Call);
       Alloc_Form_Actual : Node_Id;
       Alloc_Form_Formal : Node_Id;
+      Pool_Formal       : Node_Id;
 
    begin
       --  The allocation form generally doesn't need to be passed in the case
@@ -305,7 +310,19 @@ package body Exp_Ch6 is
 
       Add_Extra_Actual_To_Call
         (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual);
-   end Add_Alloc_Form_Actual_To_Build_In_Place_Call;
+
+      --  Pass the Storage_Pool parameter. This parameter is omitted on
+      --  .NET/JVM/ZFP as those targets do not support pools.
+
+      if VM_Target = No_VM
+        and then RTE_Available (RE_Root_Storage_Pool_Ptr)
+      then
+         Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool);
+         Analyze_And_Resolve (Pool_Actual, Etype (Pool_Formal));
+         Add_Extra_Actual_To_Call
+           (Function_Call, Pool_Formal, Pool_Actual);
+      end if;
+   end Add_Unconstrained_Actuals_To_Build_In_Place_Call;
 
    -----------------------------------------------------------
    -- Add_Finalization_Master_Actual_To_Build_In_Place_Call --
@@ -462,16 +479,23 @@ package body Exp_Ch6 is
       Function_Id   : Entity_Id;
       Master_Actual : Node_Id)
    is
-      Loc    : constant Source_Ptr := Sloc (Function_Call);
-      Actual : Node_Id := Master_Actual;
+      Loc           : constant Source_Ptr := Sloc (Function_Call);
+      Result_Subt   : constant Entity_Id :=
+                        Available_View (Etype (Function_Id));
+      Actual        : Node_Id;
+      Chain_Actual  : Node_Id;
+      Chain_Formal  : Node_Id;
+      Master_Formal : Node_Id;
 
    begin
       --  No such extra parameters are needed if there are no tasks
 
-      if not Has_Task (Available_View (Etype (Function_Id))) then
+      if not Has_Task (Result_Subt) then
          return;
       end if;
 
+      Actual := Master_Actual;
+
       --  Use a dummy _master actual in case of No_Task_Hierarchy
 
       if Restriction_Active (No_Task_Hierarchy) then
@@ -484,52 +508,34 @@ package body Exp_Ch6 is
          Actual := New_Reference_To (Actual, Loc);
       end if;
 
-      --  The master
-
-      declare
-         Master_Formal : Node_Id;
-      begin
-         --  Locate implicit master parameter in the called function
-
-         Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Master);
-
-         Analyze_And_Resolve (Actual, Etype (Master_Formal));
-
-         --  Build the parameter association for the new actual and add it to
-         --  the end of the function's actuals.
+      --  Locate the implicit master parameter in the called function
 
-         Add_Extra_Actual_To_Call (Function_Call, Master_Formal, Actual);
-      end;
+      Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Task_Master);
+      Analyze_And_Resolve (Actual, Etype (Master_Formal));
 
-      --  The activation chain
+      --  Build the parameter association for the new actual and add it to the
+      --  end of the function's actuals.
 
-      declare
-         Activation_Chain_Actual : Node_Id;
-         Activation_Chain_Formal : Node_Id;
+      Add_Extra_Actual_To_Call (Function_Call, Master_Formal, Actual);
 
-      begin
-         --  Locate implicit activation chain parameter in the called function
+      --  Locate the implicit activation chain parameter in the called function
 
-         Activation_Chain_Formal :=
-           Build_In_Place_Formal (Function_Id, BIP_Activation_Chain);
+      Chain_Formal :=
+        Build_In_Place_Formal (Function_Id, BIP_Activation_Chain);
 
-         --  Create the actual which is a pointer to the current activation
-         --  chain
+      --  Create the actual which is a pointer to the current activation chain
 
-         Activation_Chain_Actual :=
-           Make_Attribute_Reference (Loc,
-             Prefix         => Make_Identifier (Loc, Name_uChain),
-             Attribute_Name => Name_Unrestricted_Access);
+      Chain_Actual :=
+        Make_Attribute_Reference (Loc,
+          Prefix         => Make_Identifier (Loc, Name_uChain),
+          Attribute_Name => Name_Unrestricted_Access);
 
-         Analyze_And_Resolve
-           (Activation_Chain_Actual, Etype (Activation_Chain_Formal));
+      Analyze_And_Resolve (Chain_Actual, Etype (Chain_Formal));
 
-         --  Build the parameter association for the new actual and add it to
-         --  the end of the function's actuals.
+      --  Build the parameter association for the new actual and add it to the
+      --  end of the function's actuals.
 
-         Add_Extra_Actual_To_Call
-           (Function_Call, Activation_Chain_Formal, Activation_Chain_Actual);
-      end;
+      Add_Extra_Actual_To_Call (Function_Call, Chain_Formal, Chain_Actual);
    end Add_Task_Actuals_To_Build_In_Place_Call;
 
    -----------------------
@@ -541,10 +547,12 @@ package body Exp_Ch6 is
       case Kind is
          when BIP_Alloc_Form          =>
             return "BIPalloc";
+         when BIP_Storage_Pool        =>
+            return "BIPstoragepool";
          when BIP_Finalization_Master =>
             return "BIPfinalizationmaster";
-         when BIP_Master              =>
-            return "BIPmaster";
+         when BIP_Task_Master         =>
+            return "BIPtaskmaster";
          when BIP_Activation_Chain    =>
             return "BIPactivationchain";
          when BIP_Object_Access       =>
@@ -560,6 +568,9 @@ package body Exp_Ch6 is
      (Func : Entity_Id;
       Kind : BIP_Formal_Kind) return Entity_Id
    is
+      Formal_Name  : constant Name_Id :=
+                       New_External_Name
+                         (Chars (Func), BIP_Formal_Suffix (Kind));
       Extra_Formal : Entity_Id := Extra_Formals (Func);
 
    begin
@@ -578,9 +589,8 @@ package body Exp_Ch6 is
 
       loop
          pragma Assert (Present (Extra_Formal));
-         exit when
-           Chars (Extra_Formal) =
-             New_External_Name (Chars (Func), BIP_Formal_Suffix (Kind));
+         exit when Chars (Extra_Formal) = Formal_Name;
+
          Next_Formal_With_Extras (Extra_Formal);
       end loop;
 
@@ -1740,24 +1750,50 @@ package body Exp_Ch6 is
 
       if not Is_Empty_List (Post_Call) then
 
-         --  If call is not a list member, it must be the triggering statement
-         --  of a triggering alternative or an entry call alternative, and we
-         --  can add the post call stuff to the corresponding statement list.
+         --  Cases where the call is not a member of a statement list
 
          if not Is_List_Member (N) then
             declare
-               P : constant Node_Id := Parent (N);
+               P :  Node_Id := Parent (N);
 
             begin
-               pragma Assert (Nkind_In (P, N_Triggering_Alternative,
-                                           N_Entry_Call_Alternative));
+               --  In Ada 2012 the call may be a function call in an expression
+               --  (since OUT and IN OUT parameters are now allowed for such
+               --  calls. The write-back of (in)-out parameters is handled
+               --  by the back-end, but the constraint checks generated when
+               --  subtypes of formal and actual don't match must be inserted
+               --  in the form of assignments, at the nearest point after the
+               --  declaration or statement that contains the call.
+
+               if Ada_Version >= Ada_2012
+                 and then Nkind (N) = N_Function_Call
+               then
+                  while Nkind (P) not in N_Declaration
+                    and then
+                      Nkind (P) not in N_Statement_Other_Than_Procedure_Call
+                  loop
+                     P := Parent (P);
+                  end loop;
+
+                  Insert_Actions_After (P, Post_Call);
+
+               --  If not the special Ada 2012 case of a function call, then
+               --  we must have the triggering statement of a triggering
+               --  alternative or an entry call alternative, and we can add
+               --  the post call stuff to the corresponding statement list.
 
-               if Is_Non_Empty_List (Statements (P)) then
-                  Insert_List_Before_And_Analyze
-                    (First (Statements (P)), Post_Call);
                else
-                  Set_Statements (P, Post_Call);
+                  pragma Assert (Nkind_In (P, N_Triggering_Alternative,
+                                              N_Entry_Call_Alternative));
+
+                  if Is_Non_Empty_List (Statements (P)) then
+                     Insert_List_Before_And_Analyze
+                       (First (Statements (P)), Post_Call);
+                  else
+                     Set_Statements (P, Post_Call);
+                  end if;
                end if;
+
             end;
 
          --  Otherwise, normal case where N is in a statement sequence,
@@ -2642,10 +2678,13 @@ package body Exp_Ch6 is
             end if;
          end if;
 
-         --  For Ada 2012, if a parameter is aliased, the actual must be an
-         --  aliased object.
+         --  For Ada 2012, if a parameter is aliased, the actual must be a
+         --  tagged type or an aliased view of an object.
 
-         if Is_Aliased (Formal) and then not Is_Aliased_View (Actual) then
+         if Is_Aliased (Formal)
+           and then not Is_Aliased_View (Actual)
+           and then not Is_Tagged_Type (Etype (Formal))
+         then
             Error_Msg_NE
               ("actual for aliased formal& must be aliased object",
                Actual, Formal);
@@ -2751,7 +2790,7 @@ package body Exp_Ch6 is
          Next_Formal (Formal);
       end loop;
 
-      --  If we are calling an Ada2012 function which needs to have the
+      --  If we are calling an Ada 2012 function which needs to have the
       --  "accessibility level determined by the point of call" (AI05-0234)
       --  passed in to it, then pass it in.
 
@@ -3740,8 +3779,15 @@ package body Exp_Ch6 is
       New_A    : Node_Id;
       Num_Ret  : Int := 0;
       Ret_Type : Entity_Id;
-      Targ     : Node_Id;
-      Targ1    : Node_Id;
+
+      Targ : Node_Id;
+      --  The target of the call. If context is an assignment statement then
+      --  this is the left-hand side of the assignment. else it is a temporary
+      --  to which the return value is assigned prior to rewriting the call.
+
+      Targ1 : Node_Id;
+      --  A separate target used when the return type is unconstrained
+
       Temp     : Entity_Id;
       Temp_Typ : Entity_Id;
 
@@ -3749,8 +3795,8 @@ package body Exp_Ch6 is
       --  Entity in declaration in an extended_return_statement
 
       Is_Unc : constant Boolean :=
-                    Is_Array_Type (Etype (Subp))
-                      and then not Is_Constrained (Etype (Subp));
+                 Is_Array_Type (Etype (Subp))
+                   and then not Is_Constrained (Etype (Subp));
       --  If the type returned by the function is unconstrained and the call
       --  can be inlined, special processing is required.
 
@@ -3841,6 +3887,7 @@ package body Exp_Ch6 is
                   Rewrite (N, New_Copy (A));
                end if;
             end if;
+
             return Skip;
 
          elsif Is_Entity_Name (N)
@@ -3891,8 +3938,8 @@ package body Exp_Ch6 is
                if Nkind_In (Expression (N), N_Aggregate, N_Null) then
                   Ret :=
                     Make_Qualified_Expression (Sloc (N),
-                       Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
-                       Expression => Relocate_Node (Expression (N)));
+                      Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
+                      Expression => Relocate_Node (Expression (N)));
                else
                   Ret :=
                     Unchecked_Convert_To
@@ -3902,12 +3949,12 @@ package body Exp_Ch6 is
                if Nkind (Targ) = N_Defining_Identifier then
                   Rewrite (N,
                     Make_Assignment_Statement (Loc,
-                      Name => New_Occurrence_Of (Targ, Loc),
+                      Name       => New_Occurrence_Of (Targ, Loc),
                       Expression => Ret));
                else
                   Rewrite (N,
                     Make_Assignment_Statement (Loc,
-                      Name => New_Copy (Targ),
+                      Name       => New_Copy (Targ),
                       Expression => Ret));
                end if;
 
@@ -3915,19 +3962,17 @@ package body Exp_Ch6 is
 
                if Present (Exit_Lab) then
                   Insert_After (N,
-                    Make_Goto_Statement (Loc,
-                      Name => New_Copy (Lab_Id)));
+                    Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
                end if;
             end if;
 
             return OK;
 
-         elsif Nkind (N) = N_Extended_Return_Statement then
-
-            --  An extended return becomes a block whose first statement is
-            --  the assignment of the initial expression of the return object
-            --  to the target of the call itself.
+         --  An extended return becomes a block whose first statement is the
+         --  assignment of the initial expression of the return object to the
+         --  target of the call itself.
 
+         elsif Nkind (N) = N_Extended_Return_Statement then
             declare
                Return_Decl : constant Entity_Id :=
                                First (Return_Object_Declarations (N));
@@ -3940,12 +3985,12 @@ package body Exp_Ch6 is
                   if Nkind (Targ) = N_Defining_Identifier then
                      Assign :=
                        Make_Assignment_Statement (Loc,
-                         Name => New_Occurrence_Of (Targ, Loc),
+                         Name       => New_Occurrence_Of (Targ, Loc),
                          Expression => Expression (Return_Decl));
                   else
                      Assign :=
                        Make_Assignment_Statement (Loc,
-                         Name => New_Copy (Targ),
+                         Name       => New_Copy (Targ),
                          Expression => Expression (Return_Decl));
                   end if;
 
@@ -4011,7 +4056,6 @@ package body Exp_Ch6 is
            and then Nkind (Fst) = N_Assignment_Statement
            and then No (Next (Fst))
          then
-
             --  The function call may have been rewritten as the temporary
             --  that holds the result of the call, in which case remove the
             --  now useless declaration.
@@ -4031,12 +4075,20 @@ package body Exp_Ch6 is
 
             Insert_After (Parent (Entity (N)), Blk);
 
+         --  If the context is an assignment, and the left-hand side is free of
+         --  side-effects, the replacement is also safe.
+         --  Can this be generalized further???
+
          elsif Nkind (Parent (N)) = N_Assignment_Statement
            and then
             (Is_Entity_Name (Name (Parent (N)))
-               or else
-                  (Nkind (Name (Parent (N))) = N_Explicit_Dereference
-                    and then Is_Entity_Name (Prefix (Name (Parent (N))))))
+              or else
+                (Nkind (Name (Parent (N))) = N_Explicit_Dereference
+                  and then Is_Entity_Name (Prefix (Name (Parent (N)))))
+
+              or else
+                (Nkind (Name (Parent (N))) = N_Selected_Component
+                  and then Is_Entity_Name (Prefix (Name (Parent (N))))))
          then
             --  Replace assignment with the block
 
@@ -4072,6 +4124,7 @@ package body Exp_Ch6 is
 
       procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
          HSS  : constant Node_Id := Handled_Statement_Sequence (Blk);
+
       begin
          --  If there is a transient scope for N, this will be the scope of the
          --  actions for N, and the statements in Blk need to be within this
@@ -4153,7 +4206,6 @@ package body Exp_Ch6 is
    --  Start of processing for Expand_Inlined_Call
 
    begin
-
       --  Check for an illegal attempt to inline a recursive procedure. If the
       --  subprogram has parameters this is detected when trying to supply a
       --  binding for parameters that already have one. For parameterless
@@ -4201,22 +4253,27 @@ package body Exp_Ch6 is
          Set_Declarations (Blk, New_List);
       end if;
 
-      --  For the unconstrained case, capture the name of the local
-      --  variable that holds the result. This must be the first declaration
-      --  in the block, because its bounds cannot depend on local variables.
-      --  Otherwise there is no way to declare the result outside of the
-      --  block. Needless to say, in general the bounds will depend on the
-      --  actuals in the call.
+      --  For the unconstrained case, capture the name of the local variable
+      --  that holds the result. This must be the first declaration in the
+      --  block, because its bounds cannot depend on local variables. Otherwise
+      --  there is no way to declare the result outside of the block. Needless
+      --  to say, in general the bounds will depend on the actuals in the call.
+
+      --  If the context is an assignment statement, as is the case for the
+      --  expansion of an extended return, the left-hand side provides bounds
+      --  even if the return type is unconstrained.
 
       if Is_Unc then
-         Targ1 := Defining_Identifier (First (Declarations (Blk)));
+         if Nkind (Parent (N)) /= N_Assignment_Statement then
+            Targ1 := Defining_Identifier (First (Declarations (Blk)));
+         else
+            Targ1 := Name (Parent (N));
+         end if;
       end if;
 
       --  If this is a derived function, establish the proper return type
 
-      if Present (Orig_Subp)
-        and then Orig_Subp /= Subp
-      then
+      if Present (Orig_Subp) and then Orig_Subp /= Subp then
          Ret_Type := Etype (Orig_Subp);
       else
          Ret_Type := Etype (Subp);
@@ -4241,8 +4298,7 @@ package body Exp_Ch6 is
 
          if Is_Class_Wide_Type (Etype (F))
            or else (Is_Access_Type (Etype (F))
-                      and then
-                    Is_Class_Wide_Type (Designated_Type (Etype (F))))
+                     and then Is_Class_Wide_Type (Designated_Type (Etype (F))))
          then
             Temp_Typ := Etype (F);
 
@@ -4250,7 +4306,6 @@ package body Exp_Ch6 is
            and then Etype (F) /= Base_Type (Etype (F))
          then
             Temp_Typ := Etype (F);
-
          else
             Temp_Typ := Etype (A);
          end if;
@@ -4276,13 +4331,13 @@ package body Exp_Ch6 is
 
            or else
              (Nkind_In (A, N_Real_Literal,
-                            N_Integer_Literal,
-                            N_Character_Literal)
-                and then not Address_Taken (F))
+                           N_Integer_Literal,
+                           N_Character_Literal)
+               and then not Address_Taken (F))
          then
             if Etype (F) /= Etype (A) then
                Set_Renamed_Object
-                (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
+                 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
             else
                Set_Renamed_Object (F, A);
             end if;
@@ -4328,9 +4383,9 @@ package body Exp_Ch6 is
             if Ekind (F) = E_In_Parameter
               and then not Is_By_Reference_Type (Etype (A))
               and then
-               (not Is_Array_Type (Etype (A))
-                 or else not Is_Object_Reference (A)
-                 or else Is_Bit_Packed_Array (Etype (A)))
+                (not Is_Array_Type (Etype (A))
+                  or else not Is_Object_Reference (A)
+                  or else Is_Bit_Packed_Array (Etype (A)))
             then
                Decl :=
                  Make_Object_Declaration (Loc,
@@ -4372,6 +4427,12 @@ package body Exp_Ch6 is
          then
             Targ := Name (Parent (N));
 
+         elsif Nkind (Parent (N)) = N_Assignment_Statement
+           and then Nkind (Name (Parent (N))) = N_Selected_Component
+           and then Is_Entity_Name (Prefix (Name (Parent (N))))
+         then
+            Targ := New_Copy_Tree (Name (Parent (N)));
+
          elsif Nkind (Parent (N)) = N_Object_Declaration
            and then Is_Limited_Type (Etype (Subp))
          then
@@ -4388,11 +4449,13 @@ package body Exp_Ch6 is
             --  eventually be possible to remove that temporary and use the
             --  result variable directly.
 
-            if Is_Unc then
+            if Is_Unc
+              and then Nkind (Parent (N)) /= N_Assignment_Statement
+            then
                Decl :=
                  Make_Object_Declaration (Loc,
                    Defining_Identifier => Temp,
-                   Object_Definition =>
+                   Object_Definition   =>
                      New_Copy_Tree (Object_Definition (Parent (Targ1))));
 
                Replace_Formals (Decl);
@@ -4401,8 +4464,7 @@ package body Exp_Ch6 is
                Decl :=
                  Make_Object_Declaration (Loc,
                    Defining_Identifier => Temp,
-                   Object_Definition =>
-                     New_Occurrence_Of (Ret_Type, Loc));
+                   Object_Definition   => New_Occurrence_Of (Ret_Type, Loc));
 
                Set_Etype (Temp, Ret_Type);
             end if;
@@ -4422,9 +4484,7 @@ package body Exp_Ch6 is
       Replace_Formals (Blk);
       Set_Parent (Blk, N);
 
-      if not Comes_From_Source (Subp)
-        or else Is_Predef
-      then
+      if not Comes_From_Source (Subp) or else Is_Predef then
          Reset_Slocs (Blk);
       end if;
 
@@ -4436,7 +4496,7 @@ package body Exp_Ch6 is
          if Num_Ret = 1
            and then
              Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
-               N_Goto_Statement
+                                                            N_Goto_Statement
          then
             Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
          else
@@ -4474,6 +4534,7 @@ package body Exp_Ch6 is
 
       if Ekind (Subp) = E_Procedure then
          Rewrite_Procedure_Call (N, Blk);
+
       else
          Rewrite_Function_Call (N, Blk);
 
@@ -4551,6 +4612,7 @@ package body Exp_Ch6 is
 
       Par_Func     : constant Entity_Id :=
                        Return_Applies_To (Return_Statement_Entity (N));
+      Result_Subt  : constant Entity_Id := Etype (Par_Func);
       Ret_Obj_Id   : constant Entity_Id :=
                        First_Entity (Return_Statement_Entity (N));
       Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id);
@@ -4616,11 +4678,12 @@ package body Exp_Ch6 is
          Alloc_Expr : Node_Id) return Node_Id
       is
       begin
+         pragma Assert (Is_Build_In_Place_Function (Func_Id));
+
          --  Processing for build-in-place object allocation. This is disabled
          --  on .NET/JVM because the targets do not support pools.
 
          if VM_Target = No_VM
-           and then Is_Build_In_Place_Function (Func_Id)
            and then Needs_Finalization (Ret_Typ)
          then
             declare
@@ -4629,10 +4692,10 @@ package body Exp_Ch6 is
                               Build_In_Place_Formal
                                 (Func_Id, BIP_Finalization_Master);
                Stmts      : constant List_Id := New_List;
-
-               Local_Id : Entity_Id;
-               Pool_Id  : Entity_Id;
-               Ptr_Typ  : Entity_Id;
+               Desig_Typ  : Entity_Id;
+               Local_Id   : Entity_Id;
+               Pool_Id    : Entity_Id;
+               Ptr_Typ    : Entity_Id;
 
             begin
                --  Generate:
@@ -4662,8 +4725,19 @@ package body Exp_Ch6 is
                --  of the temporary. Otherwise the secondary stack allocation
                --  will fail.
 
+               Desig_Typ := Ret_Typ;
+
+               --  Ensure that the build-in-place machinery uses a fat pointer
+               --  when allocating an unconstrained array on the heap. In this
+               --  case the result object type is a constrained array type even
+               --  though the function type is unconstrained.
+
+               if Ekind (Desig_Typ) = E_Array_Subtype then
+                  Desig_Typ := Base_Type (Desig_Typ);
+               end if;
+
                --  Generate:
-               --    type Ptr_Typ is access Ret_Typ;
+               --    type Ptr_Typ is access Desig_Typ;
 
                Ptr_Typ := Make_Temporary (Loc, 'P');
 
@@ -4673,7 +4747,7 @@ package body Exp_Ch6 is
                    Type_Definition     =>
                      Make_Access_To_Object_Definition (Loc,
                        Subtype_Indication =>
-                         New_Reference_To (Ret_Typ, Loc))));
+                         New_Reference_To (Desig_Typ, Loc))));
 
                --  Perform minor decoration in order to set the master and the
                --  storage pool attributes.
@@ -4683,7 +4757,6 @@ package body Exp_Ch6 is
                Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
 
                --  Create the temporary, generate:
-               --
                --    Local_Id : Ptr_Typ;
 
                Local_Id := Make_Temporary (Loc, 'T');
@@ -4695,7 +4768,6 @@ package body Exp_Ch6 is
                      New_Reference_To (Ptr_Typ, Loc)));
 
                --  Allocate the object, generate:
-               --
                --    Local_Id := <Alloc_Expr>;
 
                Append_To (Stmts,
@@ -4743,7 +4815,6 @@ package body Exp_Ch6 is
             end;
 
          --  For all other cases, generate:
-         --
          --    Temp_Id := <Alloc_Expr>;
 
          else
@@ -4781,7 +4852,7 @@ package body Exp_Ch6 is
                --  New master
 
                New_Reference_To
-                 (Build_In_Place_Formal (Par_Func, BIP_Master), Loc)));
+                 (Build_In_Place_Formal (Par_Func, BIP_Task_Master), Loc)));
       end Move_Activation_Chain;
 
    --  Start of processing for Expand_N_Extended_Return_Statement
@@ -4846,7 +4917,7 @@ package body Exp_Ch6 is
       --  built in place (though we plan to do so eventually).
 
       if Present (HSS)
-        or else Is_Composite_Type (Etype (Par_Func))
+        or else Is_Composite_Type (Result_Subt)
         or else No (Exp)
       then
          if No (HSS) then
@@ -4873,7 +4944,7 @@ package body Exp_Ch6 is
          --  the case of result types with task parts.
 
          if Is_Build_In_Place
-           and then Has_Task (Etype (Par_Func))
+           and then Has_Task (Result_Subt)
          then
             --  The return expression is an aggregate for a complex type which
             --  contains tasks. This particular case is left unexpanded since
@@ -4884,7 +4955,12 @@ package body Exp_Ch6 is
                Expand_N_Aggregate (Exp);
             end if;
 
-            Append_To (Stmts, Move_Activation_Chain);
+            --  Do not move the activation chain if the return object does not
+            --  contain tasks.
+
+            if Has_Task (Etype (Ret_Obj_Id)) then
+               Append_To (Stmts, Move_Activation_Chain);
+            end if;
          end if;
 
          --  Update the state of the function right before the object is
@@ -4935,12 +5011,12 @@ package body Exp_Ch6 is
          Set_Identifier
            (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc));
 
-         --  If the object decl was already rewritten as a renaming, then
-         --  we don't want to do the object allocation and transformation of
-         --  of the return object declaration to a renaming. This case occurs
+         --  If the object decl was already rewritten as a renaming, then we
+         --  don't want to do the object allocation and transformation of of
+         --  the return object declaration to a renaming. This case occurs
          --  when the return object is initialized by a call to another
-         --  build-in-place function, and that function is responsible for the
-         --  allocation of the return object.
+         --  build-in-place function, and that function is responsible for
+         --  the allocation of the return object.
 
          if Is_Build_In_Place
            and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration
@@ -4983,7 +5059,6 @@ package body Exp_Ch6 is
                Return_Obj_Typ   : constant Entity_Id := Etype (Return_Obj_Id);
                Return_Obj_Expr  : constant Node_Id :=
                                     Expression (Ret_Obj_Decl);
-               Result_Subt      : constant Entity_Id := Etype (Par_Func);
                Constr_Result    : constant Boolean :=
                                     Is_Constrained (Result_Subt);
                Obj_Alloc_Formal : Entity_Id;
@@ -5086,12 +5161,16 @@ package body Exp_Ch6 is
                     Build_In_Place_Formal (Par_Func, BIP_Alloc_Form);
 
                   declare
-                     Ref_Type       : Entity_Id;
-                     Ptr_Type_Decl  : Node_Id;
+                     Pool_Id        : constant Entity_Id :=
+                                        Make_Temporary (Loc, 'P');
                      Alloc_Obj_Id   : Entity_Id;
                      Alloc_Obj_Decl : Node_Id;
                      Alloc_If_Stmt  : Node_Id;
                      Heap_Allocator : Node_Id;
+                     Pool_Decl      : Node_Id;
+                     Pool_Allocator : Node_Id;
+                     Ptr_Type_Decl  : Node_Id;
+                     Ref_Type       : Entity_Id;
                      SS_Allocator   : Node_Id;
 
                   begin
@@ -5186,6 +5265,37 @@ package body Exp_Ch6 is
                         Set_No_Initialization (Heap_Allocator);
                      end if;
 
+                     --  The Pool_Allocator is just like the Heap_Allocator,
+                     --  except we set Storage_Pool and Procedure_To_Call so
+                     --  it will use the user-defined storage pool.
+
+                     Pool_Allocator := New_Copy_Tree (Heap_Allocator);
+
+                     --  Do not generate the renaming of the build-in-place
+                     --  pool parameter on .NET/JVM/ZFP because the parameter
+                     --  is not created in the first place.
+
+                     if VM_Target = No_VM
+                       and then RTE_Available (RE_Root_Storage_Pool_Ptr)
+                     then
+                        Pool_Decl :=
+                          Make_Object_Renaming_Declaration (Loc,
+                            Defining_Identifier => Pool_Id,
+                            Subtype_Mark        =>
+                              New_Reference_To
+                                (RTE (RE_Root_Storage_Pool), Loc),
+                            Name                =>
+                              Make_Explicit_Dereference (Loc,
+                                New_Reference_To
+                                  (Build_In_Place_Formal
+                                     (Par_Func, BIP_Storage_Pool), Loc)));
+                        Set_Storage_Pool (Pool_Allocator, Pool_Id);
+                        Set_Procedure_To_Call
+                          (Pool_Allocator, RTE (RE_Allocate_Any));
+                     else
+                        Pool_Decl := Make_Null_Statement (Loc);
+                     end if;
+
                      --  If the No_Allocators restriction is active, then only
                      --  an allocator for secondary stack allocation is needed.
                      --  It's OK for such allocators to have Comes_From_Source
@@ -5195,22 +5305,25 @@ package body Exp_Ch6 is
                      if Restriction_Active (No_Allocators) then
                         SS_Allocator   := Heap_Allocator;
                         Heap_Allocator := Make_Null (Loc);
+                        Pool_Allocator := Make_Null (Loc);
 
-                     --  Otherwise the heap allocator may be needed, so we make
-                     --  another allocator for secondary stack allocation.
+                     --  Otherwise the heap and pool allocators may be needed,
+                     --  so we make another allocator for secondary stack
+                     --  allocation.
 
                      else
                         SS_Allocator := New_Copy_Tree (Heap_Allocator);
 
-                        --  The heap allocator is marked Comes_From_Source
-                        --  since it corresponds to an explicit user-written
-                        --  allocator (that is, it will only be executed on
-                        --  behalf of callers that call the function as
-                        --  initialization for such an allocator). This
-                        --  prevents errors when No_Implicit_Heap_Allocations
+                        --  The heap and pool allocators are marked as
+                        --  Comes_From_Source since they correspond to an
+                        --  explicit user-written allocator (that is, it will
+                        --  only be executed on behalf of callers that call the
+                        --  function as initialization for such an allocator).
+                        --  Prevents errors when No_Implicit_Heap_Allocations
                         --  is in force.
 
                         Set_Comes_From_Source (Heap_Allocator, True);
+                        Set_Comes_From_Source (Pool_Allocator, True);
                      end if;
 
                      --  The allocator is returned on the secondary stack. We
@@ -5224,9 +5337,9 @@ package body Exp_Ch6 is
                         --  The allocator is returned on the secondary stack,
                         --  so indicate that the function return, as well as
                         --  the block that encloses the allocator, must not
-                        --  release it. The flags must be set now because the
-                        --  decision to use the secondary stack is done very
-                        --  late in the course of expanding the return
+                        --  release it. The flags must be set now because
+                        --  the decision to use the secondary stack is done
+                        --  very late in the course of expanding the return
                         --  statement, past the point where these flags are
                         --  normally set.
 
@@ -5239,10 +5352,12 @@ package body Exp_Ch6 is
 
                      --  Create an if statement to test the BIP_Alloc_Form
                      --  formal and initialize the access object to either the
-                     --  BIP_Object_Access formal (BIP_Alloc_Form = 0), the
-                     --  result of allocating the object in the secondary stack
-                     --  (BIP_Alloc_Form = 1), or else an allocator to create
-                     --  the return object in the heap (BIP_Alloc_Form = 2).
+                     --  BIP_Object_Access formal (BIP_Alloc_Form =
+                     --  Caller_Allocation), the result of allocating the
+                     --  object in the secondary stack (BIP_Alloc_Form =
+                     --  Secondary_Stack), or else an allocator to create the
+                     --  return object in the heap or user-defined pool
+                     --  (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).
 
                      --  ??? An unchecked type conversion must be made in the
                      --  case of assigning the access object formal to the
@@ -5290,23 +5405,42 @@ package body Exp_Ch6 is
                                Make_Assignment_Statement (Loc,
                                  Name       =>
                                    New_Reference_To (Alloc_Obj_Id, Loc),
-                                 Expression => SS_Allocator)))),
+                                 Expression => SS_Allocator))),
+
+                           Make_Elsif_Part (Loc,
+                             Condition =>
+                               Make_Op_Eq (Loc,
+                                 Left_Opnd  =>
+                                   New_Reference_To (Obj_Alloc_Formal, Loc),
+                                 Right_Opnd =>
+                                   Make_Integer_Literal (Loc,
+                                     UI_From_Int (BIP_Allocation_Form'Pos
+                                                    (Global_Heap)))),
+
+                             Then_Statements => New_List (
+                               Build_Heap_Allocator
+                                 (Temp_Id    => Alloc_Obj_Id,
+                                  Temp_Typ   => Ref_Type,
+                                  Func_Id    => Par_Func,
+                                  Ret_Typ    => Return_Obj_Typ,
+                                  Alloc_Expr => Heap_Allocator)))),
 
                          Else_Statements => New_List (
+                           Pool_Decl,
                            Build_Heap_Allocator
                              (Temp_Id    => Alloc_Obj_Id,
                               Temp_Typ   => Ref_Type,
                               Func_Id    => Par_Func,
                               Ret_Typ    => Return_Obj_Typ,
-                              Alloc_Expr => Heap_Allocator)));
+                              Alloc_Expr => Pool_Allocator)));
 
                      --  If a separate initialization assignment was created
                      --  earlier, append that following the assignment of the
                      --  implicit access formal to the access object, to ensure
-                     --  that the return object is initialized in that case.
-                     --  In this situation, the target of the assignment must
-                     --  be rewritten to denote a dereference of the access to
-                     --  the return object passed in by the caller.
+                     --  that the return object is initialized in that case. In
+                     --  this situation, the target of the assignment must be
+                     --  rewritten to denote a dereference of the access to the
+                     --  return object passed in by the caller.
 
                      if Present (Init_Assignment) then
                         Rewrite (Name (Init_Assignment),
@@ -5574,10 +5708,14 @@ package body Exp_Ch6 is
       end if;
 
       --  If local-exception-to-goto optimization active, insert dummy push
-      --  statements at start, and dummy pop statements at end.
+      --  statements at start, and dummy pop statements at end, but inhibit
+      --  this if we have No_Exception_Handlers, since they are useless and
+      --  intefere with analysis, e.g. by codepeer.
 
       if (Debug_Flag_Dot_G
            or else Restriction_Active (No_Exception_Propagation))
+        and then not Restriction_Active (No_Exception_Handlers)
+        and then not CodePeer_Mode
         and then Is_Non_Empty_List (L)
       then
          declare
@@ -5954,10 +6092,10 @@ package body Exp_Ch6 is
             Pop_Scope;
          end if;
 
-      --  Ada 2005 (AI-348): Generate body for a null procedure.
-      --  In most cases this is superfluous because calls to it
-      --  will be automatically inlined, but we definitely need
-      --  the body if preconditions for the procedure are present.
+      --  Ada 2005 (AI-348): Generate body for a null procedure. In most
+      --  cases this is superfluous because calls to it will be automatically
+      --  inlined, but we definitely need the body if preconditions for the
+      --  procedure are present.
 
       elsif Nkind (Specification (N)) = N_Procedure_Specification
         and then Null_Present (Specification (N))
@@ -5995,11 +6133,11 @@ package body Exp_Ch6 is
 
    begin
       --  Call _Postconditions procedure if procedure with active
-      --  postconditions. Here, we use the Postcondition_Proc attribute, which
-      --  is needed for implicitly-generated returns. Functions never
-      --  have implicitly-generated returns, and there's no room for
-      --  Postcondition_Proc in E_Function, so we look up the identifier
-      --  Name_uPostconditions for function returns (see
+      --  postconditions. Here, we use the Postcondition_Proc attribute,
+      --  which is needed for implicitly-generated returns. Functions
+      --  never have implicitly-generated returns, and there's no
+      --  room for Postcondition_Proc in E_Function, so we look up the
+      --  identifier Name_uPostconditions for function returns (see
       --  Expand_Simple_Function_Return).
 
       if Ekind (Scope_Id) = E_Procedure
@@ -6204,13 +6342,13 @@ package body Exp_Ch6 is
       Rec   : Node_Id;
 
    begin
-      --  If the protected object is not an enclosing scope, this is an
-      --  inter-object function call. Inter-object procedure calls are expanded
-      --  by Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if
-      --  the subprogram being called is in the protected body being compiled,
-      --  and if the protected object in the call is statically the enclosing
-      --  type. The object may be an component of some other data structure, in
-      --  which case this must be handled as an inter-object call.
+      --  If the protected object is not an enclosing scope, this is an inter-
+      --  object function call. Inter-object procedure calls are expanded by
+      --  Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if the
+      --  subprogram being called is in the protected body being compiled, and
+      --  if the protected object in the call is statically the enclosing type.
+      --  The object may be an component of some other data structure, in which
+      --  case this must be handled as an inter-object call.
 
       if not In_Open_Scopes (Scop)
         or else not Is_Entity_Name (Name (N))
@@ -6290,8 +6428,8 @@ package body Exp_Ch6 is
    -- Expand_Simple_Function_Return --
    -----------------------------------
 
-   --  The "simple" comes from the syntax rule simple_return_statement.
-   --  The semantics are not at all simple!
+   --  The "simple" comes from the syntax rule simple_return_statement. The
+   --  semantics are not at all simple!
 
    procedure Expand_Simple_Function_Return (N : Node_Id) is
       Loc : constant Source_Ptr := Sloc (N);
@@ -6312,12 +6450,12 @@ package body Exp_Ch6 is
       --  The type of the expression (not necessarily the same as R_Type)
 
       Subtype_Ind : Node_Id;
-      --  If the result type of the function is class-wide and the
-      --  expression has a specific type, then we use the expression's
-      --  type as the type of the return object. In cases where the
-      --  expression is an aggregate that is built in place, this avoids
-      --  the need for an expensive conversion of the return object to
-      --  the specific type on assignments to the individual components.
+      --  If the result type of the function is class-wide and the expression
+      --  has a specific type, then we use the expression's type as the type of
+      --  the return object. In cases where the expression is an aggregate that
+      --  is built in place, this avoids the need for an expensive conversion
+      --  of the return object to the specific type on assignments to the
+      --  individual components.
 
    begin
       if Is_Class_Wide_Type (R_Type)
@@ -6481,13 +6619,13 @@ package body Exp_Ch6 is
          --  Optimize the case where the result is a function call. In this
          --  case either the result is already on the secondary stack, or is
          --  already being returned with the stack pointer depressed and no
-         --  further processing is required except to set the By_Ref flag to
-         --  ensure that gigi does not attempt an extra unnecessary copy.
+         --  further processing is required except to set the By_Ref flag
+         --  to ensure that gigi does not attempt an extra unnecessary copy.
          --  (actually not just unnecessary but harmfully wrong in the case
          --  of a controlled type, where gigi does not know how to do a copy).
-         --  To make up for a gcc 2.8.1 deficiency (???), we perform
-         --  the copy for array types if the constrained status of the
-         --  target type is different from that of the expression.
+         --  To make up for a gcc 2.8.1 deficiency (???), we perform the copy
+         --  for array types if the constrained status of the target type is
+         --  different from that of the expression.
 
          if Requires_Transient_Scope (Exptyp)
            and then
@@ -6562,6 +6700,14 @@ package body Exp_Ch6 is
                  Make_Explicit_Dereference (Loc,
                  Prefix => New_Reference_To (Temp, Loc)));
 
+               --  Ada 2005 (AI-251): If the type of the returned object is
+               --  an interface then add an implicit type conversion to force
+               --  displacement of the "this" pointer.
+
+               if Is_Interface (R_Type) then
+                  Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp)));
+               end if;
+
                Analyze_And_Resolve (Exp, R_Type);
             end;
 
@@ -6581,12 +6727,12 @@ package body Exp_Ch6 is
          end if;
       end if;
 
-      --  Implement the rules of 6.5(8-10), which require a tag check in the
-      --  case of a limited tagged return type, and tag reassignment for
+      --  Implement the rules of 6.5(8-10), which require a tag check in
+      --  the case of a limited tagged return type, and tag reassignment for
       --  nonlimited tagged results. These actions are needed when the return
       --  type is a specific tagged type and the result expression is a
-      --  conversion or a formal parameter, because in that case the tag of the
-      --  expression might differ from the tag of the specific result type.
+      --  conversion or a formal parameter, because in that case the tag of
+      --  the expression might differ from the tag of the specific result type.
 
       if Is_Tagged_Type (Utyp)
         and then not Is_Class_Wide_Type (Utyp)
@@ -6595,8 +6741,8 @@ package body Exp_Ch6 is
                     or else (Is_Entity_Name (Exp)
                                and then Ekind (Entity (Exp)) in Formal_Kind))
       then
-         --  When the return type is limited, perform a check that the
-         --  tag of the result is the same as the tag of the return type.
+         --  When the return type is limited, perform a check that the tag of
+         --  the result is the same as the tag of the return type.
 
          if Is_Limited_Type (R_Type) then
             Insert_Action (Exp,
@@ -6616,8 +6762,8 @@ package body Exp_Ch6 is
 
          --  If the result type is a specific nonlimited tagged type, then we
          --  have to ensure that the tag of the result is that of the result
-         --  type. This is handled by making a copy of the expression in the
-         --  case where it might have a different tag, namely when the
+         --  type. This is handled by making a copy of the expression in
+         --  the case where it might have a different tag, namely when the
          --  expression is a conversion or a formal parameter. We create a new
          --  object of the result type and initialize it from the expression,
          --  which will implicitly force the tag to be set appropriately.
@@ -6817,9 +6963,9 @@ package body Exp_Ch6 is
             case Nkind (Discrim_Source) is
                when N_Defining_Identifier =>
 
-                  pragma Assert (Is_Composite_Type (Discrim_Source) and then
-                                 Has_Discriminants (Discrim_Source) and then
-                                 Is_Constrained (Discrim_Source));
+                  pragma Assert (Is_Composite_Type (Discrim_Source)
+                                  and then Has_Discriminants (Discrim_Source)
+                                  and then Is_Constrained (Discrim_Source));
 
                   declare
                      Discrim   : Entity_Id :=
@@ -6830,8 +6976,8 @@ package body Exp_Ch6 is
                   begin
                      loop
                         if Ekind (Etype (Discrim)) =
-                          E_Anonymous_Access_Type then
-
+                             E_Anonymous_Access_Type
+                        then
                            Check_Against_Result_Level
                              (Dynamic_Accessibility_Level (Node (Disc_Elmt)));
                         end if;
@@ -6844,8 +6990,8 @@ package body Exp_Ch6 is
 
                when N_Aggregate | N_Extension_Aggregate =>
 
-                  --  Unimplemented: extension aggregate case where
-                  --  discrims come from ancestor part, not extension part.
+                  --  Unimplemented: extension aggregate case where discrims
+                  --  come from ancestor part, not extension part.
 
                   declare
                      Discrim  : Entity_Id :=
@@ -6873,18 +7019,19 @@ package body Exp_Ch6 is
                        (Comp_Id : Entity_Id;
                         Associations : List_Id) return Node_Id
                      is
-                        Assoc  : Node_Id := First (Associations);
+                        Assoc  : Node_Id;
                         Choice : Node_Id;
+
                      begin
                         --  Simple linear search seems ok here
 
+                        Assoc := First (Associations);
                         while Present (Assoc) loop
                            Choice := First (Choices (Assoc));
-
                            while Present (Choice) loop
                               if (Nkind (Choice) = N_Identifier
-                                  and then Chars (Choice) = Chars (Comp_Id))
-                                 or else (Nkind (Choice) = N_Others_Choice)
+                                   and then Chars (Choice) = Chars (Comp_Id))
+                                or else (Nkind (Choice) = N_Others_Choice)
                               then
                                  return Expression (Assoc);
                               end if;
@@ -6907,13 +7054,15 @@ package body Exp_Ch6 is
 
                      loop
                         if Positionals_Exhausted then
-                           Disc_Exp := Associated_Expr (Discrim,
-                             Component_Associations (Discrim_Source));
+                           Disc_Exp :=
+                             Associated_Expr
+                               (Discrim,
+                                Component_Associations (Discrim_Source));
                         end if;
 
                         if Ekind (Etype (Discrim)) =
-                          E_Anonymous_Access_Type then
-
+                             E_Anonymous_Access_Type
+                        then
                            Check_Against_Result_Level
                              (Dynamic_Accessibility_Level (Disc_Exp));
                         end if;
@@ -6929,15 +7078,18 @@ package body Exp_Ch6 is
                   end;
 
                when N_Function_Call =>
-                  --  No check needed; check performed by callee.
+
+                  --  No check needed (check performed by callee)
+
                   null;
 
                when others =>
 
                   declare
                      Level : constant Node_Id :=
-                        Make_Integer_Literal (Loc,
-                          Object_Access_Level (Discrim_Source));
+                               Make_Integer_Literal (Loc,
+                                 Object_Access_Level (Discrim_Source));
+
                   begin
                      --  Unimplemented: check for name prefix that includes
                      --  a dereference of an access value with a dynamic
@@ -6945,6 +7097,7 @@ package body Exp_Ch6 is
                      --  saooaaat) and use dynamic level in that case. For
                      --  example:
                      --    return Access_Param.all(Some_Index).Some_Component;
+                     --  ???
 
                      Set_Etype (Level, Standard_Natural);
                      Check_Against_Result_Level (Level);
@@ -7257,9 +7410,9 @@ package body Exp_Ch6 is
                  Thunk_Code,
 
                  Build_Set_Predefined_Prim_Op_Address (Loc,
-                   Tag_Node =>
+                   Tag_Node     =>
                      New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
-                   Position => DT_Position (Prim),
+                   Position     => DT_Position (Prim),
                    Address_Node =>
                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                        Make_Attribute_Reference (Loc,
@@ -7267,11 +7420,11 @@ package body Exp_Ch6 is
                          Attribute_Name => Name_Unrestricted_Access))),
 
                  Build_Set_Predefined_Prim_Op_Address (Loc,
-                   Tag_Node =>
+                   Tag_Node     =>
                      New_Reference_To
                       (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))),
                        Loc),
-                   Position => DT_Position (Prim),
+                   Position     => DT_Position (Prim),
                    Address_Node =>
                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                        Make_Attribute_Reference (Loc,
@@ -7284,13 +7437,12 @@ package body Exp_Ch6 is
             Next_Elmt (Iface_DT_Ptr);
             pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
 
-            --  Skip the tag of the no-thunks dispatch table
+            --  Skip tag of the no-thunks dispatch table
 
             Next_Elmt (Iface_DT_Ptr);
             pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
 
-            --  Skip the tag of the predefined primitives no-thunks dispatch
-            --  table.
+            --  Skip tag of predefined primitives no-thunks dispatch table
 
             Next_Elmt (Iface_DT_Ptr);
             pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
@@ -7342,8 +7494,8 @@ package body Exp_Ch6 is
             --  slots.
 
             elsif Is_Imported (Subp)
-                    and then (Convention (Subp) = Convention_CPP
-                                or else Convention (Subp) = Convention_C)
+               and then (Convention (Subp) = Convention_CPP
+                           or else Convention (Subp) = Convention_C)
             then
                null;
 
@@ -7556,7 +7708,7 @@ package body Exp_Ch6 is
          --  called as a dispatching operation and must be treated similarly
          --  to functions with unconstrained result subtypes.
 
-         Add_Alloc_Form_Actual_To_Build_In_Place_Call
+         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
@@ -7587,11 +7739,30 @@ package body Exp_Ch6 is
       --  operations. ???
 
       else
-         --  Pass an allocation parameter indicating that the function should
-         --  allocate its result on the heap.
+         --  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
+         --  pool may not be aliased.
 
-         Add_Alloc_Form_Actual_To_Build_In_Place_Call
-           (Func_Call, Function_Id, Alloc_Form => Global_Heap);
+         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_Reference_To
+                       (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);
+         end if;
 
          Add_Finalization_Master_Actual_To_Build_In_Place_Call
            (Func_Call, Function_Id, Acc_Type);
@@ -7642,6 +7813,15 @@ package body Exp_Ch6 is
       --  to the object created by the allocator).
 
       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;
+
       Analyze_And_Resolve (Allocator, Acc_Type);
    end Make_Build_In_Place_Call_In_Allocator;
 
@@ -7760,7 +7940,7 @@ package body Exp_Ch6 is
          --  called as a dispatching operation and must be treated similarly
          --  to functions with unconstrained result subtypes.
 
-         Add_Alloc_Form_Actual_To_Build_In_Place_Call
+         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
@@ -7784,7 +7964,7 @@ package body Exp_Ch6 is
          --  Pass an allocation parameter indicating that the function should
          --  allocate its result on the secondary stack.
 
-         Add_Alloc_Form_Actual_To_Build_In_Place_Call
+         Add_Unconstrained_Actuals_To_Build_In_Place_Call
            (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
 
          Add_Finalization_Master_Actual_To_Build_In_Place_Call
@@ -7817,6 +7997,7 @@ package body Exp_Ch6 is
       Obj_Id       : Entity_Id;
       Ptr_Typ      : Entity_Id;
       Ptr_Typ_Decl : Node_Id;
+      New_Expr     : Node_Id;
       Result_Subt  : Entity_Id;
       Target       : Node_Id;
 
@@ -7862,7 +8043,7 @@ package body Exp_Ch6 is
       --  controlling result, because dispatching calls to the function needs
       --  to be treated effectively the same as calls to class-wide functions.
 
-      Add_Alloc_Form_Actual_To_Build_In_Place_Call
+      Add_Unconstrained_Actuals_To_Build_In_Place_Call
         (Func_Call, Func_Id, Alloc_Form => Caller_Allocation);
 
       Add_Finalization_Master_Actual_To_Build_In_Place_Call
@@ -7896,16 +8077,20 @@ package body Exp_Ch6 is
       Insert_After_And_Analyze (Assign, Ptr_Typ_Decl);
 
       --  Finally, create an access object initialized to a reference to the
-      --  function call.
+      --  function call. We know this access value is non-null, so mark the
+      --  entity accordingly to suppress junk access checks.
+
+      New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call));
 
-      Obj_Id := Make_Temporary (Loc, 'R');
+      Obj_Id := Make_Temporary (Loc, 'R', New_Expr);
       Set_Etype (Obj_Id, Ptr_Typ);
+      Set_Is_Known_Non_Null (Obj_Id);
 
       Obj_Decl :=
         Make_Object_Declaration (Loc,
           Defining_Identifier => Obj_Id,
           Object_Definition   => New_Reference_To (Ptr_Typ, Loc),
-          Expression => Make_Reference (Loc, Relocate_Node (Func_Call)));
+          Expression          => New_Expr);
       Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl);
 
       Rewrite (Assign, Make_Null_Statement (Loc));
@@ -7942,20 +8127,20 @@ package body Exp_Ch6 is
       Loc             : Source_Ptr;
       Obj_Def_Id      : constant Entity_Id :=
                           Defining_Identifier (Object_Decl);
-
-      Func_Call       : Node_Id := Function_Call;
-      Function_Id     : Entity_Id;
-      Result_Subt     : Entity_Id;
-      Caller_Object   : Node_Id;
-      Call_Deref      : Node_Id;
-      Ref_Type        : Entity_Id;
-      Ptr_Typ_Decl    : Node_Id;
-      Def_Id          : Entity_Id;
-      New_Expr        : Node_Id;
       Enclosing_Func  : constant Entity_Id :=
                           Enclosing_Subprogram (Obj_Def_Id);
+      Call_Deref      : Node_Id;
+      Caller_Object   : Node_Id;
+      Def_Id          : Entity_Id;
       Fmaster_Actual  : Node_Id := Empty;
+      Func_Call       : Node_Id := Function_Call;
+      Function_Id     : Entity_Id;
+      Pool_Actual     : Node_Id;
+      Ptr_Typ_Decl    : Node_Id;
       Pass_Caller_Acc : Boolean := False;
+      New_Expr        : Node_Id;
+      Ref_Type        : Entity_Id;
+      Result_Subt     : Entity_Id;
 
    begin
       --  Step past qualification or unchecked conversion (the latter can occur
@@ -8011,19 +8196,33 @@ package body Exp_Ch6 is
          --  has an unconstrained or tagged result type).
 
          if Needs_BIP_Alloc_Form (Enclosing_Func) then
-            Add_Alloc_Form_Actual_To_Build_In_Place_Call
+            if VM_Target = No_VM and then
+              RTE_Available (RE_Root_Storage_Pool_Ptr)
+            then
+               Pool_Actual :=
+                 New_Reference_To (Build_In_Place_Formal
+                   (Enclosing_Func, BIP_Storage_Pool), Loc);
+
+            --  The build-in-place pool formal is not built on .NET/JVM
+
+            else
+               Pool_Actual := Empty;
+            end if;
+
+            Add_Unconstrained_Actuals_To_Build_In_Place_Call
               (Func_Call,
                Function_Id,
                Alloc_Form_Exp =>
                  New_Reference_To
                    (Build_In_Place_Formal (Enclosing_Func, BIP_Alloc_Form),
-                    Loc));
+                    Loc),
+               Pool_Actual => Pool_Actual);
 
          --  Otherwise, if enclosing function has a constrained result subtype,
          --  then caller allocation will be used.
 
          else
-            Add_Alloc_Form_Actual_To_Build_In_Place_Call
+            Add_Unconstrained_Actuals_To_Build_In_Place_Call
               (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
          end if;
 
@@ -8066,7 +8265,7 @@ package body Exp_Ch6 is
          --  called as a dispatching operation and must be treated similarly
          --  to functions with unconstrained result subtypes.
 
-         Add_Alloc_Form_Actual_To_Build_In_Place_Call
+         Add_Unconstrained_Actuals_To_Build_In_Place_Call
            (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
 
       --  In other unconstrained cases, pass an indication to do the allocation
@@ -8075,10 +8274,8 @@ package body Exp_Ch6 is
       --  scope is established to ensure eventual cleanup of the result.
 
       else
-         Add_Alloc_Form_Actual_To_Build_In_Place_Call
-           (Func_Call,
-            Function_Id,
-            Alloc_Form => Secondary_Stack);
+         Add_Unconstrained_Actuals_To_Build_In_Place_Call
+           (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
          Caller_Object := Empty;
 
          Establish_Transient_Scope (Object_Decl, Sec_Stack => True);
@@ -8102,8 +8299,8 @@ package body Exp_Ch6 is
          Add_Task_Actuals_To_Build_In_Place_Call
            (Func_Call, Function_Id,
             Master_Actual =>
-              New_Reference_To
-                (Build_In_Place_Formal (Enclosing_Func, BIP_Master), Loc));
+              New_Reference_To (Build_In_Place_Formal
+                (Enclosing_Func, BIP_Task_Master), Loc));
 
       else
          Add_Task_Actuals_To_Build_In_Place_Call
@@ -8146,12 +8343,14 @@ package body Exp_Ch6 is
       end if;
 
       --  Finally, create an access object initialized to a reference to the
-      --  function call.
+      --  function call. We know this access value cannot be null, so mark the
+      --  entity accordingly to suppress the access check.
 
       New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call));
 
       Def_Id := Make_Temporary (Loc, 'R', New_Expr);
       Set_Etype (Def_Id, Ref_Type);
+      Set_Is_Known_Non_Null (Def_Id);
 
       Insert_After_And_Analyze (Ptr_Typ_Decl,
         Make_Object_Declaration (Loc,
@@ -8255,7 +8454,6 @@ package body Exp_Ch6 is
    is
       pragma Assert (Is_Build_In_Place_Function (Func_Id));
       Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
-
    begin
       return
         not Restriction_Active (No_Finalization)
@@ -8351,14 +8549,14 @@ package body Exp_Ch6 is
          return False;
 
       --  Handle a corner case, a cross-dialect subp renaming. For example,
-      --  an Ada2012 renaming of an Ada05 subprogram. This can occur when a
-      --  non-Ada2012 unit references predefined runtime units.
+      --  an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when
+      --  an Ada 2005 (or earlier) unit references predefined run-time units.
 
       elsif Present (Alias (Func_Id)) then
 
          --  Unimplemented: a cross-dialect subp renaming which does not set
          --  the Alias attribute (e.g., a rename of a dereference of an access
-         --  to subprogram value).
+         --  to subprogram value). ???
 
          return Present (Extra_Accessibility_Of_Result (Alias (Func_Id)));