OSDN Git Service

* common.opt (Wmudflap): New option.
[pf3gnuchains/gcc-fork.git] / gcc / ada / exp_ch6.adb
index e1d245b..e8f5c11 100644 (file)
@@ -6,18 +6,17 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
--- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
 -- for  more details.  You should have  received  a copy of the GNU General --
--- Public License  distributed with GNAT;  see file COPYING.  If not, write --
--- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
--- Boston, MA 02110-1301, USA.                                              --
+-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license.          --
 --                                                                          --
 -- GNAT was originally developed  by the GNAT team at  New York University. --
 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
@@ -44,9 +43,9 @@ with Exp_Tss;  use Exp_Tss;
 with Exp_Util; use Exp_Util;
 with Fname;    use Fname;
 with Freeze;   use Freeze;
-with Hostparm; use Hostparm;
 with Inline;   use Inline;
 with Lib;      use Lib;
+with Namet;    use Namet;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
 with Opt;      use Opt;
@@ -67,8 +66,8 @@ with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
 with Snames;   use Snames;
 with Stand;    use Stand;
+with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
-with Ttypes;   use Ttypes;
 with Uintp;    use Uintp;
 with Validsw;  use Validsw;
 
@@ -110,10 +109,14 @@ package body Exp_Ch6 is
 
    procedure Add_Final_List_Actual_To_Build_In_Place_Call
      (Function_Call : Node_Id;
-      Function_Id   : Entity_Id);
+      Function_Id   : Entity_Id;
+      Acc_Type      : Entity_Id);
    --  Ada 2005 (AI-318-02): For a build-in-place call, if the result type has
-   --  controlled parts, add an actual parameter that is a pointer to caller's
-   --  finalization list.
+   --  controlled parts, add an actual parameter that is a pointer to
+   --  appropriate finalization list. The finalization list is that of the
+   --  current scope, except for "new Acc'(F(...))" in which case it's the
+   --  finalization list of the access type returned by the allocator. Acc_Type
+   --  is that type in the allocator case; Empty otherwise.
 
    procedure Add_Task_Actuals_To_Build_In_Place_Call
      (Function_Call : Node_Id;
@@ -230,6 +233,7 @@ package body Exp_Ch6 is
 
       if not Present (Return_Object) then
          Obj_Address := Make_Null (Loc);
+         Set_Parent (Obj_Address, Function_Call);
 
       --  If Return_Object is already an expression of an access type, then use
       --  it directly, since it must be an access value denoting the return
@@ -237,6 +241,7 @@ package body Exp_Ch6 is
 
       elsif Is_Access then
          Obj_Address := Return_Object;
+         Set_Parent (Obj_Address, Function_Call);
 
       --  Apply Unrestricted_Access to caller's return object
 
@@ -245,6 +250,9 @@ package body Exp_Ch6 is
             Make_Attribute_Reference (Loc,
               Prefix         => Return_Object,
               Attribute_Name => Name_Unrestricted_Access);
+
+         Set_Parent (Return_Object, Obj_Address);
+         Set_Parent (Obj_Address, Function_Call);
       end if;
 
       Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal));
@@ -270,6 +278,19 @@ package body Exp_Ch6 is
       Alloc_Form_Formal : Node_Id;
 
    begin
+      --  The allocation form generally doesn't need to be passed in the case
+      --  of a constrained result subtype, since normally the caller performs
+      --  the allocation in that case. However this formal is still needed in
+      --  the case where the function has a tagged result, because generally
+      --  such functions can be called in a dispatching context and such calls
+      --  must be handled like calls to class-wide functions.
+
+      if Is_Constrained (Underlying_Type (Etype (Function_Id)))
+        and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id)))
+      then
+         return;
+      end if;
+
       --  Locate the implicit allocation form parameter in the called function.
       --  Maybe it would be better for each implicit formal of a build-in-place
       --  function to have a flag or a Uint attribute to identify it. ???
@@ -357,7 +378,8 @@ package body Exp_Ch6 is
 
    procedure Add_Final_List_Actual_To_Build_In_Place_Call
      (Function_Call : Node_Id;
-      Function_Id   : Entity_Id)
+      Function_Id   : Entity_Id;
+      Acc_Type      : Entity_Id)
    is
       Loc               : constant Source_Ptr := Sloc (Function_Call);
       Final_List        : Node_Id;
@@ -365,10 +387,17 @@ package body Exp_Ch6 is
       Final_List_Formal : Node_Id;
 
    begin
-      --  No such extra parameter is needed if there are no controlled parts
-
-      if not (Is_Controlled (Etype (Function_Id))
-              or else Has_Controlled_Component (Etype (Function_Id))) then
+      --  No such extra parameter is needed if there are no controlled parts.
+      --  The test for Controlled_Type accounts for class-wide results (which
+      --  potentially have controlled parts, even if the root type doesn't),
+      --  and the test for a tagged result type is needed because calls to
+      --  such a function can in general occur in dispatching contexts, which
+      --  must be treated the same as a call to class-wide functions. Both of
+      --  these situations require that a finalization list be passed.
+
+      if not Controlled_Type (Underlying_Type (Etype (Function_Id)))
+        and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id)))
+      then
          return;
       end if;
 
@@ -376,9 +405,21 @@ package body Exp_Ch6 is
 
       Final_List_Formal := Build_In_Place_Formal (Function_Id, BIP_Final_List);
 
-      --  Create the actual which is a pointer to the current finalization list
+      --  Create the actual which is a pointer to the appropriate finalization
+      --  list. Acc_Type is present if and only if this call is the
+      --  initialization of an allocator. Use the Current_Scope or the Acc_Type
+      --  as appropriate.
+
+      if Present (Acc_Type)
+        and then (Ekind (Acc_Type) = E_Anonymous_Access_Type
+                   or else
+                     Present (Associated_Final_Chain (Base_Type (Acc_Type))))
+      then
+         Final_List := Find_Final_List (Acc_Type);
+      else
+         Final_List := Find_Final_List (Current_Scope);
+      end if;
 
-      Final_List := Find_Final_List (Current_Scope);
       Final_List_Actual :=
         Make_Attribute_Reference (Loc,
           Prefix         => Final_List,
@@ -495,13 +536,13 @@ package body Exp_Ch6 is
       --  function to have a flag or a Uint attribute to identify it. ???
 
       loop
+         pragma Assert (Present (Extra_Formal));
          exit when
            Chars (Extra_Formal) =
              New_External_Name (Chars (Func), BIP_Formal_Suffix (Kind));
          Next_Formal_With_Extras (Extra_Formal);
       end loop;
 
-      pragma Assert (Present (Extra_Formal));
       return Extra_Formal;
    end Build_In_Place_Formal;
 
@@ -735,7 +776,7 @@ package body Exp_Ch6 is
       --  Push our current scope for analyzing the declarations and code that
       --  we will insert for the checking.
 
-      New_Scope (Spec);
+      Push_Scope (Spec);
 
       --  This loop builds temporary variables for each of the referenced
       --  globals, so that at the end of the loop the list Shad_List contains
@@ -1081,13 +1122,48 @@ package body Exp_Ch6 is
             Rewrite (Actual, New_Reference_To (Temp, Loc));
             Analyze (Actual);
 
-            Append_To (Post_Call,
-              Make_Assignment_Statement (Loc,
-                Name       => New_Occurrence_Of (Var, Loc),
-                Expression => Expr));
+            --  If the actual is a conversion of a packed reference, it may
+            --  already have been expanded by Remove_Side_Effects, and the
+            --  resulting variable is a temporary which does not designate
+            --  the proper out-parameter, which may not be addressable. In
+            --  that case, generate an assignment to the original expression
+            --  (before expansion of the  packed reference) so that the proper
+            --  expansion of assignment to a packed component can take place.
 
-            Set_Assignment_OK (Name (Last (Post_Call)));
+            declare
+               Obj : Node_Id;
+               Lhs : Node_Id;
+
+            begin
+               if Is_Renaming_Of_Object (Var)
+                 and then Nkind (Renamed_Object (Var)) = N_Selected_Component
+                 and then Is_Entity_Name (Prefix (Renamed_Object (Var)))
+                 and then Nkind (Original_Node (Prefix (Renamed_Object (Var))))
+                   = N_Indexed_Component
+                 and then
+                   Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var))))
+               then
+                  Obj := Renamed_Object (Var);
+                  Lhs :=
+                    Make_Selected_Component (Loc,
+                      Prefix        =>
+                        New_Copy_Tree (Original_Node (Prefix (Obj))),
+                      Selector_Name => New_Copy (Selector_Name (Obj)));
+                  Reset_Analyzed_Flags (Lhs);
+
+               else
+                  Lhs :=  New_Occurrence_Of (Var, Loc);
+               end if;
+
+               Set_Assignment_OK (Lhs);
+
+               Append_To (Post_Call,
+                 Make_Assignment_Statement (Loc,
+                   Name       => Lhs,
+                   Expression => Expr));
+            end;
          end if;
+
       end Add_Call_By_Copy_Code;
 
       ----------------------------------
@@ -1261,7 +1337,7 @@ package body Exp_Ch6 is
             return False;
 
          --  For users of Starlet, we assume that the specification of by-
-         --  reference mechanism is mandatory. This may lead to unligned
+         --  reference mechanism is mandatory. This may lead to unaligned
          --  objects but at least for DEC legacy code it is known to work.
          --  The warning will alert users of this code that a problem may
          --  be lurking.
@@ -1315,8 +1391,8 @@ package body Exp_Ch6 is
       begin
          loop
             Set_Analyzed (Pfx, False);
-            exit when Nkind (Pfx) /= N_Selected_Component
-              and then Nkind (Pfx) /= N_Indexed_Component;
+            exit when
+              not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component);
             Pfx := Prefix (Pfx);
          end loop;
       end Reset_Packed_Prefix;
@@ -1461,7 +1537,7 @@ package body Exp_Ch6 is
             elsif Is_Possibly_Unaligned_Slice (Actual) then
                Add_Call_By_Copy_Code;
 
-            --  Deal with access types where the actual subtpe and the
+            --  Deal with access types where the actual subtype and the
             --  formal subtype are not the same, requiring a check.
 
             --  It is necessary to exclude tagged types because of "downward
@@ -1557,8 +1633,8 @@ package body Exp_Ch6 is
                P : constant Node_Id := Parent (N);
 
             begin
-               pragma Assert (Nkind (P) = N_Triggering_Alternative
-                 or else Nkind (P) = N_Entry_Call_Alternative);
+               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
@@ -1603,25 +1679,8 @@ package body Exp_Ch6 is
 
    procedure Expand_Call (N : Node_Id) is
       Loc           : constant Source_Ptr := Sloc (N);
-      Remote        : constant Boolean    := Is_Remote_Call (N);
-      Subp          : Entity_Id;
-      Orig_Subp     : Entity_Id := Empty;
-      Parent_Subp   : Entity_Id;
-      Parent_Formal : Entity_Id;
-      Actual        : Node_Id;
-      Formal        : Entity_Id;
-      Prev          : Node_Id := Empty;
-
-      Prev_Orig : Node_Id;
-      --  Original node for an actual, which may have been rewritten. If the
-      --  actual is a function call that has been transformed from a selected
-      --  component, the original node is unanalyzed. Otherwise, it carries
-      --  semantic information used to generate additional actuals.
-
-      Scop          : Entity_Id;
       Extra_Actuals : List_Id := No_List;
-
-      CW_Interface_Formals_Present : Boolean := False;
+      Prev          : Node_Id := Empty;
 
       procedure Add_Actual_Parameter (Insert_Param : Node_Id);
       --  Adds one entry to the end of the actual parameter list. Used for
@@ -1750,6 +1809,13 @@ package body Exp_Ch6 is
             Gen_Par := Generic_Parent_Type (Parent (Par));
          end if;
 
+         --  If the actual has no generic parent type, the formal is not
+         --  a formal derived type, so nothing to inherit.
+
+         if No (Gen_Par) then
+            return Empty;
+         end if;
+
          --  If the generic parent type is still the generic type, this is a
          --  private formal, not a derived formal, and there are no operations
          --  inherited from the formal.
@@ -1795,6 +1861,26 @@ package body Exp_Ch6 is
          raise Program_Error;
       end Inherited_From_Formal;
 
+      --  Local variables
+
+      Remote        : constant Boolean := Is_Remote_Call (N);
+      Actual        : Node_Id;
+      Formal        : Entity_Id;
+      Orig_Subp     : Entity_Id := Empty;
+      Param_Count   : Natural := 0;
+      Parent_Formal : Entity_Id;
+      Parent_Subp   : Entity_Id;
+      Scop          : Entity_Id;
+      Subp          : Entity_Id;
+
+      Prev_Orig     : Node_Id;
+      --  Original node for an actual, which may have been rewritten. If the
+      --  actual is a function call that has been transformed from a selected
+      --  component, the original node is unanalyzed. Otherwise, it carries
+      --  semantic information used to generate additional actuals.
+
+      CW_Interface_Formals_Present : Boolean := False;
+
    --  Start of processing for Expand_Call
 
    begin
@@ -1835,8 +1921,12 @@ package body Exp_Ch6 is
          --  if we can tell that the first parameter cannot possibly be null.
          --  This helps optimization and also generation of warnings.
 
-         if not Restriction_Active (No_Exception_Handlers)
-           and then Is_RTE (Subp, RE_Raise_Exception)
+         --  We do not do this if Raise_Exception_Always does not exist, which
+         --  can happen in configurable run time profiles which provide only a
+         --  Raise_Exception, which is in fact an unconditional raise anyway.
+
+         if Is_RTE (Subp, RE_Raise_Exception)
+           and then RTE_Available (RE_Raise_Exception_Always)
          then
             declare
                FA : constant Node_Id := Original_Node (First_Actual (N));
@@ -1850,7 +1940,7 @@ package body Exp_Ch6 is
                  and then Attribute_Name (FA) = Name_Identity
                then
                   Subp := RTE (RE_Raise_Exception_Always);
-                  Set_Entity (Name (N), Subp);
+                  Set_Name (N, New_Occurrence_Of (Subp, Loc));
                end if;
             end;
          end if;
@@ -1911,8 +2001,9 @@ package body Exp_Ch6 is
       --  We also generate any required range checks for actuals as we go
       --  through the loop, since this is a convenient place to do this.
 
-      Formal := First_Formal (Subp);
-      Actual := First_Actual (N);
+      Formal      := First_Formal (Subp);
+      Actual      := First_Actual (N);
+      Param_Count := 1;
       while Present (Formal) loop
 
          --  Generate range check if required (not activated yet ???)
@@ -1928,8 +2019,11 @@ package body Exp_Ch6 is
          Prev := Actual;
          Prev_Orig := Original_Node (Prev);
 
+         --  The original actual may have been a call written in prefix
+         --  form, and rewritten before analysis.
+
          if not Analyzed (Prev_Orig)
-           and then Nkind (Actual) = N_Function_Call
+           and then Nkind_In (Actual, N_Function_Call, N_Identifier)
          then
             Prev_Orig := Prev;
          end if;
@@ -1990,8 +2084,8 @@ package body Exp_Ch6 is
                   --  as out parameter actuals on calls to stream procedures.
 
                   Act_Prev := Prev;
-                  while Nkind (Act_Prev) = N_Type_Conversion
-                    or else Nkind (Act_Prev) = N_Unchecked_Type_Conversion
+                  while Nkind_In (Act_Prev, N_Type_Conversion,
+                                            N_Unchecked_Type_Conversion)
                   loop
                      Act_Prev := Expression (Act_Prev);
                   end loop;
@@ -2026,15 +2120,68 @@ package body Exp_Ch6 is
          --  Create possible extra actual for accessibility level
 
          if Present (Extra_Accessibility (Formal)) then
-            if Is_Entity_Name (Prev_Orig) then
 
-               --  When passing an access parameter as the actual to another
-               --  access parameter we need to pass along the actual's own
-               --  associated access level parameter. This is done if we are
-               --  in the scope of the formal access parameter (if this is an
-               --  inlined body the extra formal is irrelevant).
+            --  Ada 2005 (AI-252): If the actual was rewritten as an Access
+            --  attribute, then the original actual may be an aliased object
+            --  occurring as the prefix in a call using "Object.Operation"
+            --  notation. In that case we must pass the level of the object,
+            --  so Prev_Orig is reset to Prev and the attribute will be
+            --  processed by the code for Access attributes further below.
+
+            if Prev_Orig /= Prev
+              and then Nkind (Prev) = N_Attribute_Reference
+              and then
+                Get_Attribute_Id (Attribute_Name (Prev)) = Attribute_Access
+              and then Is_Aliased_View (Prev_Orig)
+            then
+               Prev_Orig := Prev;
+            end if;
+
+            --  Ada 2005 (AI-251): Thunks must propagate the extra actuals
+            --  of accessibility levels.
+
+            if Ekind (Current_Scope) in Subprogram_Kind
+              and then Is_Thunk (Current_Scope)
+            then
+               declare
+                  Parm_Ent : Entity_Id;
+
+               begin
+                  if Is_Controlling_Actual (Actual) then
+
+                     --  Find the corresponding actual of the thunk
+
+                     Parm_Ent := First_Entity (Current_Scope);
+                     for J in 2 .. Param_Count loop
+                        Next_Entity (Parm_Ent);
+                     end loop;
 
-               if Ekind (Entity (Prev_Orig)) in Formal_Kind
+                  else pragma Assert (Is_Entity_Name (Actual));
+                     Parm_Ent := Entity (Actual);
+                  end if;
+
+                  Add_Extra_Actual
+                    (New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc),
+                     Extra_Accessibility (Formal));
+               end;
+
+            elsif Is_Entity_Name (Prev_Orig) then
+
+               --  When passing an access parameter, or a renaming of an access
+               --  parameter, as the actual to another access parameter we need
+               --  to pass along the actual's own access level parameter. This
+               --  is done if we are within the scope of the formal access
+               --  parameter (if this is an inlined body the extra formal is
+               --  irrelevant).
+
+               if (Is_Formal (Entity (Prev_Orig))
+                    or else
+                      (Present (Renamed_Object (Entity (Prev_Orig)))
+                        and then
+                          Is_Entity_Name (Renamed_Object (Entity (Prev_Orig)))
+                        and then
+                          Is_Formal
+                            (Entity (Renamed_Object (Entity (Prev_Orig))))))
                  and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type
                  and then In_Open_Scopes (Scope (Entity (Prev_Orig)))
                then
@@ -2063,8 +2210,8 @@ package body Exp_Ch6 is
                      end if;
                   end;
 
-               --  The actual is a normal access value, so just pass the
-               --  level of the actual's access type.
+               --  The actual is a normal access value, so just pass the level
+               --  of the actual's access type.
 
                else
                   Add_Extra_Actual
@@ -2073,11 +2220,12 @@ package body Exp_Ch6 is
                      Extra_Accessibility (Formal));
                end if;
 
+            --  All cases other than thunks
+
             else
                case Nkind (Prev_Orig) is
 
                   when N_Attribute_Reference =>
-
                      case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is
 
                         --  For X'Access, pass on the level of the prefix X
@@ -2142,7 +2290,7 @@ package body Exp_Ch6 is
             if Is_Access_Type (Etype (Formal))
               and then Can_Never_Be_Null (Etype (Formal))
               and then Nkind (Prev) /= N_Raise_Constraint_Error
-              and then (Nkind (Prev) = N_Null
+              and then (Known_Null (Prev)
                           or else not Can_Never_Be_Null (Etype (Prev)))
             then
                Install_Null_Excluding_Check (Prev);
@@ -2167,16 +2315,16 @@ package body Exp_Ch6 is
             then
                null;
 
-            elsif Nkind (Prev) = N_Allocator
-              or else Nkind (Prev) = N_Attribute_Reference
-            then
+            elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then
                null;
 
             --  Suppress null checks when passing to access parameters of Java
-            --  subprograms. (Should this be done for other foreign conventions
-            --  as well ???)
+            --  and CIL subprograms. (Should this be done for other foreign
+            --  conventions as well ???)
 
-            elsif Convention (Subp) = Convention_Java then
+            elsif Convention (Subp) = Convention_Java
+              or else Convention (Subp) = Convention_CIL
+            then
                null;
 
             else
@@ -2194,14 +2342,27 @@ package body Exp_Ch6 is
                 (Ekind (Formal) = E_In_Out_Parameter
                    and then Validity_Check_In_Out_Params)
             then
-               --  If the actual is an indexed component of a packed
-               --  type, it has not been expanded yet. It will be
-               --  copied in the validity code that follows, and has
-               --  to be expanded appropriately, so reanalyze it.
+               --  If the actual is an indexed component of a packed type (or
+               --  is an indexed or selected component whose prefix recursively
+               --  meets this condition), it has not been expanded yet. It will
+               --  be copied in the validity code that follows, and has to be
+               --  expanded appropriately, so reanalyze it.
 
-               if Nkind (Actual) = N_Indexed_Component then
-                  Set_Analyzed (Actual, False);
-               end if;
+               --  What we do is just to unset analyzed bits on prefixes till
+               --  we reach something that does not have a prefix.
+
+               declare
+                  Nod : Node_Id;
+
+               begin
+                  Nod := Actual;
+                  while Nkind_In (Nod, N_Indexed_Component,
+                                       N_Selected_Component)
+                  loop
+                     Set_Analyzed (Nod, False);
+                     Nod := Prefix (Nod);
+                  end loop;
+               end;
 
                Ensure_Valid (Actual);
             end if;
@@ -2245,8 +2406,33 @@ package body Exp_Ch6 is
 
          if Ekind (Formal) /= E_In_Parameter
            and then Is_Entity_Name (Actual)
+           and then Present (Entity (Actual))
          then
-            Kill_Current_Values (Entity (Actual));
+            declare
+               Ent : constant Entity_Id := Entity (Actual);
+               Sav : Node_Id;
+
+            begin
+               --  For an OUT or IN OUT parameter that is an assignable entity,
+               --  we do not want to clobber the Last_Assignment field, since
+               --  if it is set, it was precisely because it is indeed an OUT
+               --  or IN OUT parameter!
+
+               if (Ekind (Formal) = E_Out_Parameter
+                     or else
+                   Ekind (Formal) = E_In_Out_Parameter)
+                 and then Is_Assignable (Ent)
+               then
+                  Sav := Last_Assignment (Ent);
+                  Kill_Current_Values (Ent);
+                  Set_Last_Assignment (Ent, Sav);
+
+                  --  For all other cases, just kill the current values
+
+               else
+                  Kill_Current_Values (Ent);
+               end if;
+            end;
          end if;
 
          --  If the formal is class wide and the actual is an aggregate, force
@@ -2266,21 +2452,10 @@ package body Exp_Ch6 is
          --  In a remote call, if the formal is of a class-wide type, check
          --  that the actual meets the requirements described in E.4(18).
 
-         if Remote
-           and then Is_Class_Wide_Type (Etype (Formal))
-         then
+         if Remote and then Is_Class_Wide_Type (Etype (Formal)) then
             Insert_Action (Actual,
-              Make_Implicit_If_Statement (N,
-                Condition       =>
-                  Make_Op_Not (Loc,
-                    Build_Get_Remotely_Callable (Loc,
-                      Make_Selected_Component (Loc,
-                        Prefix => Duplicate_Subexpr_Move_Checks (Actual),
-                        Selector_Name =>
-                          Make_Identifier (Loc, Name_uTag)))),
-                Then_Statements => New_List (
-                  Make_Raise_Program_Error (Loc,
-                    Reason => PE_Illegal_RACW_E_4_18))));
+              Make_Transportable_Check (Loc,
+                Duplicate_Subexpr_Move_Checks (Actual)));
          end if;
 
          --  This label is required when skipping extra actual generation for
@@ -2288,6 +2463,7 @@ package body Exp_Ch6 is
 
          <<Skip_Extra_Actual_Generation>>
 
+         Param_Count := Param_Count + 1;
          Next_Actual (Actual);
          Next_Formal (Formal);
       end loop;
@@ -2329,7 +2505,7 @@ package body Exp_Ch6 is
                   then
                      Error_Msg_NE
                        ("tag-indeterminate expression "
-                         & " must have designated type& ('R'M 5.2 (6))",
+                         & " must have designated type& (RM 5.2 (6))",
                            N, Root_Type (Etype (Name (Ass))));
                   else
                      Propagate_Tag (Name (Ass), N);
@@ -2338,7 +2514,7 @@ package body Exp_Ch6 is
                elsif Etype (N) /= Root_Type (Etype (Name (Ass))) then
                   Error_Msg_NE
                     ("tag-indeterminate expression must have type&"
-                     & "('R'M 5.2 (6))", N, Root_Type (Etype (Name (Ass))));
+                     & "(RM 5.2 (6))", N, Root_Type (Etype (Name (Ass))));
 
                else
                   Propagate_Tag (Name (Ass), N);
@@ -2355,8 +2531,7 @@ package body Exp_Ch6 is
       --  Ada 2005 (AI-251): If some formal is a class-wide interface, expand
       --  it to point to the correct secondary virtual table
 
-      if (Nkind (N) = N_Function_Call
-           or else Nkind (N) = N_Procedure_Call_Statement)
+      if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
         and then CW_Interface_Formals_Present
       then
          Expand_Interface_Actuals (N);
@@ -2366,14 +2541,13 @@ package body Exp_Ch6 is
       --  extra actuals since this will be done on the re-analysis of the
       --  dispatching call. Note that we do not try to shorten the actual
       --  list for a dispatching call, it would not make sense to do so.
-      --  Expansion of dispatching calls is suppressed when Java_VM, because
-      --  the JVM back end directly handles the generation of dispatching
+      --  Expansion of dispatching calls is suppressed when VM_Target, because
+      --  the VM back-ends directly handle the generation of dispatching
       --  calls and would have to undo any expansion to an indirect call.
 
-      if (Nkind (N) = N_Function_Call
-           or else Nkind (N) =  N_Procedure_Call_Statement)
+      if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
         and then Present (Controlling_Argument (N))
-        and then not Java_VM
+        and then VM_Target = No_VM
       then
          Expand_Dispatching_Call (N);
 
@@ -2627,9 +2801,21 @@ package body Exp_Ch6 is
       --  In the case where the intrinsic is to be processed by the back end,
       --  the call to Expand_Intrinsic_Call will do nothing, which is fine,
       --  since the idea in this case is to pass the call unchanged.
+      --  If the intrinsic is an inherited unchecked conversion, and the
+      --  derived type is the target type of the conversion, we must retain
+      --  it as the return type of the expression. Otherwise the expansion
+      --  below, which uses the parent operation, will yield the wrong type.
 
       if Is_Intrinsic_Subprogram (Subp) then
          Expand_Intrinsic_Call (N, Subp);
+
+         if Nkind (N) = N_Unchecked_Type_Conversion
+           and then Parent_Subp /= Orig_Subp
+           and then Etype (Parent_Subp) /= Etype (Orig_Subp)
+         then
+            Set_Etype (N, Etype (Orig_Subp));
+         end if;
+
          return;
       end if;
 
@@ -2708,7 +2894,7 @@ package body Exp_Ch6 is
 
                   if (In_Extended_Main_Code_Unit (N)
                         or else In_Extended_Main_Code_Unit (Parent (N))
-                        or else Is_Always_Inlined (Subp))
+                        or else Has_Pragma_Inline_Always (Subp))
                     and then (not In_Same_Extended_Unit (Sloc (Bod), Loc)
                                or else
                                  Earlier_In_Extended_Unit (Sloc (Bod), Loc))
@@ -2780,9 +2966,12 @@ package body Exp_Ch6 is
       end if;
 
       --  Functions returning controlled objects need special attention
+      --  If the return type is limited the context is an initialization
+      --  and different processing applies.
 
       if Controlled_Type (Etype (Subp))
         and then not Is_Inherently_Limited_Type (Etype (Subp))
+        and then not Is_Limited_Interface (Etype (Subp))
       then
          Expand_Ctrl_Function_Call (N);
       end if;
@@ -2842,10 +3031,6 @@ package body Exp_Ch6 is
             --  If no arguments, delete entire list, this is the easy case
 
             if No (Last_Keep_Arg) then
-               while Is_Non_Empty_List (Parameter_Associations (N)) loop
-                  Delete_Tree (Remove_Head (Parameter_Associations (N)));
-               end loop;
-
                Set_Parameter_Associations (N, No_List);
                Set_First_Named_Actual (N, Empty);
 
@@ -2856,7 +3041,7 @@ package body Exp_Ch6 is
 
             elsif Is_List_Member (Last_Keep_Arg) then
                while Present (Next (Last_Keep_Arg)) loop
-                  Delete_Tree (Remove_Next (Last_Keep_Arg));
+                  Discard_Node (Remove_Next (Last_Keep_Arg));
                end loop;
 
                Set_First_Named_Actual (N, Empty);
@@ -2871,9 +3056,6 @@ package body Exp_Ch6 is
                   Temp   : Node_Id;
                   Passoc : Node_Id;
 
-                  Discard : Node_Id;
-                  pragma Warnings (Off, Discard);
-
                begin
                   --  First step, remove all the named parameters from the
                   --  list (they are still chained using First_Named_Actual
@@ -2896,7 +3078,7 @@ package body Exp_Ch6 is
                      end loop;
 
                      while Present (Next (Temp)) loop
-                        Discard := Remove_Next (Temp);
+                        Remove (Next (Temp));
                      end loop;
                   end if;
 
@@ -2923,7 +3105,6 @@ package body Exp_Ch6 is
                      exit when No (Temp);
                      Set_Next_Named_Actual
                        (Passoc, Next_Named_Actual (Parent (Temp)));
-                     Delete_Tree (Temp);
                   end loop;
                end;
             end if;
@@ -2936,9 +3117,15 @@ package body Exp_Ch6 is
       --  parameter to Raise_Exception is a use of Identity, since in these
       --  cases we know that the parameter is never null.
 
+      --  Note: We must check that the node has not been inlined. This is
+      --  required because under zfp the Raise_Exception subprogram has the
+      --  pragma inline_always (and hence the call has been expanded above
+      --  into a block containing the code of the subprogram).
+
       if Ada_Version >= Ada_05
         and then not GNAT_Mode
         and then Is_RTE (Subp, RE_Raise_Exception)
+        and then Nkind (N) = N_Procedure_Call_Statement
         and then (Nkind (First_Actual (N)) /= N_Attribute_Reference
                    or else Attribute_Name (First_Actual (N)) /= Name_Identity)
       then
@@ -3036,7 +3223,7 @@ package body Exp_Ch6 is
          elsif Nkind (Orig_Bod) /= N_Subprogram_Body then
             return False;
 
-         --  Check if this is an ada 2005 null procedure
+         --  Check if this is an Ada 2005 null procedure
 
          elsif Nkind (Decl) = N_Subprogram_Declaration
            and then Null_Present (Specification (Decl))
@@ -3060,7 +3247,7 @@ package body Exp_Ch6 is
                    and then
                      (No (Stat2)
                        or else
-                         (Nkind (Stat2) = N_Return_Statement
+                         (Nkind (Stat2) = N_Simple_Return_Statement
                            and then No (Next (Stat2))));
             end;
          end if;
@@ -3124,19 +3311,21 @@ package body Exp_Ch6 is
                   Rewrite (N, New_Occurrence_Of (A, Loc));
                   Check_Private_View (N);
 
-               else   --  numeric literal
+               --  Numeric literal
+
+               else
                   Rewrite (N, New_Copy (A));
                end if;
             end if;
 
             return Skip;
 
-         elsif Nkind (N) = N_Return_Statement then
-
+         elsif Nkind (N) = N_Simple_Return_Statement then
             if No (Expression (N)) then
                Make_Exit_Label;
-               Rewrite (N, Make_Goto_Statement (Loc,
-                 Name => New_Copy (Lab_Id)));
+               Rewrite (N,
+                 Make_Goto_Statement (Loc,
+                   Name => New_Copy (Lab_Id)));
 
             else
                if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
@@ -3160,9 +3349,7 @@ package body Exp_Ch6 is
                --  use a qualified expression, because an aggregate is not a
                --  legal argument of a conversion.
 
-               if Nkind (Expression (N)) = N_Aggregate
-                 or else Nkind (Expression (N)) = N_Null
-               then
+               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)),
@@ -3508,6 +3695,10 @@ package body Exp_Ch6 is
          --  If the actual is a simple name or a literal, no need to
          --  create a temporary, object can be used directly.
 
+         --  If the actual is a literal and the formal has its address taken,
+         --  we cannot pass the literal itself as an argument, so its value
+         --  must be captured in a temporary.
+
          if (Is_Entity_Name (A)
               and then
                (not Is_Scalar_Type (Etype (A))
@@ -3520,9 +3711,11 @@ package body Exp_Ch6 is
            or else (Nkind (A) = N_Identifier
              and then Formal_Is_Used_Once (F))
 
-           or else Nkind (A) = N_Real_Literal
-           or else Nkind (A) = N_Integer_Literal
-           or else Nkind (A) = N_Character_Literal
+           or else
+             (Nkind_In (A, N_Real_Literal,
+                            N_Integer_Literal,
+                            N_Character_Literal)
+                and then not Address_Taken (F))
          then
             if Etype (F) /= Etype (A) then
                Set_Renamed_Object
@@ -3563,7 +3756,7 @@ package body Exp_Ch6 is
 
             --  If the actual has a by-reference type, it cannot be copied, so
             --  its value is captured in a renaming declaration. Otherwise
-            --  declare a local constant initalized with the actual.
+            --  declare a local constant initialized with the actual.
 
             if Ekind (F) = E_In_Parameter
               and then not Is_Limited_Type (Etype (A))
@@ -3739,190 +3932,8 @@ package body Exp_Ch6 is
    ----------------------------
 
    procedure Expand_N_Function_Call (N : Node_Id) is
-      Typ   : constant Entity_Id := Etype (N);
-
-      function Returned_By_Reference return Boolean;
-      --  If the return type is returned through the secondary stack; that is
-      --  by reference, we don't want to create a temp to force stack checking.
-      --  ???"sec stack" is not right -- Ada 95 return-by-reference object are
-      --  returned whereever they are.
-      --  Shouldn't this function be moved to exp_util???
-
-      function Rhs_Of_Assign_Or_Decl (N : Node_Id) return Boolean;
-      --  If the call is the right side of an assignment or the expression in
-      --  an object declaration, we don't need to create a temp as the left
-      --  side will already trigger stack checking if necessary.
-      --
-      --  If the call is a component in an extension aggregate, it will be
-      --  expanded into assignments as well, so no temporary is needed. This
-      --  also solves the problem of functions returning types with unknown
-      --  discriminants, where it is not possible to declare an object of the
-      --  type altogether.
-
-      ---------------------------
-      -- Returned_By_Reference --
-      ---------------------------
-
-      function Returned_By_Reference return Boolean is
-         S : Entity_Id;
-
-      begin
-         if Is_Inherently_Limited_Type (Typ) then
-            return True;
-
-         elsif Nkind (Parent (N)) /= N_Return_Statement then
-            return False;
-
-         elsif Requires_Transient_Scope (Typ) then
-
-            --  Verify that the return type of the enclosing function has the
-            --  same constrained status as that of the expression.
-
-            S := Current_Scope;
-            while Ekind (S) /= E_Function loop
-               S := Scope (S);
-            end loop;
-
-            return Is_Constrained (Typ) = Is_Constrained (Etype (S));
-         else
-            return False;
-         end if;
-      end Returned_By_Reference;
-
-      ---------------------------
-      -- Rhs_Of_Assign_Or_Decl --
-      ---------------------------
-
-      function Rhs_Of_Assign_Or_Decl (N : Node_Id) return Boolean is
-      begin
-         if (Nkind (Parent (N)) = N_Assignment_Statement
-               and then Expression (Parent (N)) = N)
-           or else
-             (Nkind (Parent (N)) = N_Qualified_Expression
-                and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
-                  and then Expression (Parent (Parent (N))) = Parent (N))
-           or else
-             (Nkind (Parent (N)) = N_Object_Declaration
-                and then Expression (Parent (N)) = N)
-           or else
-             (Nkind (Parent (N)) = N_Component_Association
-                and then Expression (Parent (N)) = N
-                  and then Nkind (Parent (Parent (N))) = N_Aggregate
-                    and then Rhs_Of_Assign_Or_Decl (Parent (Parent (N))))
-           or else
-             (Nkind (Parent (N)) = N_Extension_Aggregate
-               and then Is_Private_Type (Etype (Typ)))
-         then
-            return True;
-         else
-            return False;
-         end if;
-      end Rhs_Of_Assign_Or_Decl;
-
-   --  Start of processing for Expand_N_Function_Call
-
    begin
-      --  A special check. If stack checking is enabled, and the return type
-      --  might generate a large temporary, and the call is not the right side
-      --  of an assignment, then generate an explicit temporary. We do this
-      --  because otherwise gigi may generate a large temporary on the fly and
-      --  this can cause trouble with stack checking.
-
-      --  This is unecessary if the call is the expression in an object
-      --  declaration, or if it appears outside of any library unit. This can
-      --  only happen if it appears as an actual in a library-level instance,
-      --  in which case a temporary will be generated for it once the instance
-      --  itself is installed.
-
-      if May_Generate_Large_Temp (Typ)
-        and then not Rhs_Of_Assign_Or_Decl (N)
-        and then not Returned_By_Reference
-        and then Current_Scope /= Standard_Standard
-      then
-         if Stack_Checking_Enabled then
-
-            --  Note: it might be thought that it would be OK to use a call to
-            --  Force_Evaluation here, but that's not good enough, because
-            --  that can results in a 'Reference construct that may still need
-            --  a temporary.
-
-            declare
-               Loc      : constant Source_Ptr := Sloc (N);
-               Temp_Obj : constant Entity_Id :=
-                            Make_Defining_Identifier (Loc,
-                              Chars => New_Internal_Name ('F'));
-               Temp_Typ : Entity_Id := Typ;
-               Decl     : Node_Id;
-               A        : Node_Id;
-               F        : Entity_Id;
-               Proc     : Entity_Id;
-
-            begin
-               if Is_Tagged_Type (Typ)
-                 and then Present (Controlling_Argument (N))
-               then
-                  if Nkind (Parent (N)) /= N_Procedure_Call_Statement
-                    and then Nkind (Parent (N)) /= N_Function_Call
-                  then
-                     --  If this is a tag-indeterminate call, the object must
-                     --  be classwide.
-
-                     if Is_Tag_Indeterminate (N) then
-                        Temp_Typ := Class_Wide_Type (Typ);
-                     end if;
-
-                  else
-                     --  If this is a dispatching call that is itself the
-                     --  controlling argument of an enclosing call, the
-                     --  nominal subtype of the object that replaces it must
-                     --  be classwide, so that dispatching will take place
-                     --  properly. If it is not a controlling argument, the
-                     --  object is not classwide.
-
-                     Proc := Entity (Name (Parent (N)));
-
-                     F := First_Formal (Proc);
-                     A := First_Actual (Parent (N));
-                     while A /= N loop
-                        Next_Formal (F);
-                        Next_Actual (A);
-                     end loop;
-
-                     if Is_Controlling_Formal (F) then
-                        Temp_Typ := Class_Wide_Type (Typ);
-                     end if;
-                  end if;
-               end if;
-
-               Decl :=
-                 Make_Object_Declaration (Loc,
-                   Defining_Identifier => Temp_Obj,
-                   Object_Definition   => New_Occurrence_Of (Temp_Typ, Loc),
-                   Constant_Present    => True,
-                   Expression          => Relocate_Node (N));
-               Set_Assignment_OK (Decl);
-
-               Insert_Actions (N, New_List (Decl));
-               Rewrite (N, New_Occurrence_Of (Temp_Obj, Loc));
-            end;
-
-         else
-            --  If stack-checking is not enabled, increment serial number
-            --  for internal names, so that subsequent symbols are consistent
-            --  with and without stack-checking.
-
-            Synchronize_Serial_Number;
-
-            --  Now we can expand the call with consistent symbol names
-
-            Expand_Call (N);
-         end if;
-
-      --  Normal case, expand the call
-
-      else
-         Expand_Call (N);
-      end if;
+      Expand_Call (N);
    end Expand_N_Function_Call;
 
    ---------------------------------------
@@ -3941,6 +3952,9 @@ package body Exp_Ch6 is
    --  Add poll call if ATC polling is enabled, unless the body will be
    --  inlined by the back-end.
 
+   --  Add dummy push/pop label nodes at start and end to clear any local
+   --  exception indications if local-exception-to-goto optimization active.
+
    --  Add return statement if last statement in body is not a return statement
    --  (this makes things easier on Gigi which does not want to have to handle
    --  a missing return).
@@ -3977,189 +3991,49 @@ package body Exp_Ch6 is
       --  the latter test is not critical, it does not matter if we add a
       --  few extra returns, since they get eliminated anyway later on.
 
-      procedure Expand_Thread_Body;
-      --  Perform required expansion of a thread body
-
       ----------------
       -- Add_Return --
       ----------------
 
       procedure Add_Return (S : List_Id) is
-      begin
-         if not Is_Transfer (Last (S)) then
-
-            --  The source location for the return is the end label
-            --  of the procedure in all cases. This is a bit odd when
-            --  there are exception handlers, but not much else we can do.
-
-            Append_To (S, Make_Return_Statement (Sloc (End_Label (H))));
-         end if;
-      end Add_Return;
-
-      ------------------------
-      -- Expand_Thread_Body --
-      ------------------------
-
-      --  The required expansion of a thread body is as follows
-
-      --  procedure <thread body procedure name> is
-
-      --    _Secondary_Stack : aliased
-      --       Storage_Elements.Storage_Array
-      --         (1 .. Storage_Offset (Sec_Stack_Size));
-      --    for _Secondary_Stack'Alignment use Standard'Maximum_Alignment;
-
-      --    _Process_ATSD : aliased System.Threads.ATSD;
-
-      --  begin
-      --     System.Threads.Thread_Body_Enter;
-      --       (_Secondary_Stack'Address,
-      --        _Secondary_Stack'Length,
-      --        _Process_ATSD'Address);
-
-      --     declare
-      --        <user declarations>
-      --     begin
-      --        <user statements>
-      --     <user exception handlers>
-      --     end;
-
-      --    System.Threads.Thread_Body_Leave;
-
-      --  exception
-      --     when E : others =>
-      --       System.Threads.Thread_Body_Exceptional_Exit (E);
-      --  end;
-
-      --  Note the exception handler is omitted if pragma Restriction
-      --  No_Exception_Handlers is currently active.
-
-      procedure Expand_Thread_Body is
-         User_Decls    : constant List_Id := Declarations (N);
-         Sec_Stack_Len : Node_Id;
-
-         TB_Pragma  : constant Node_Id :=
-                        Get_Rep_Pragma (Spec_Id, Name_Thread_Body);
-
-         Ent_SS   : Entity_Id;
-         Ent_ATSD : Entity_Id;
-         Ent_EO   : Entity_Id;
-
-         Decl_SS   : Node_Id;
-         Decl_ATSD : Node_Id;
-
-         Excep_Handlers : List_Id;
+         Last_Stm : Node_Id;
+         Loc      : Source_Ptr;
 
       begin
-         New_Scope (Spec_Id);
-
-         --  Get proper setting for secondary stack size
+         --  Get last statement, ignoring any Pop_xxx_Label nodes, which are
+         --  not relevant in this context since they are not executable.
 
-         if List_Length (Pragma_Argument_Associations (TB_Pragma)) = 2 then
-            Sec_Stack_Len :=
-              Expression (Last (Pragma_Argument_Associations (TB_Pragma)));
-         else
-            Sec_Stack_Len :=
-              New_Occurrence_Of (RTE (RE_Default_Secondary_Stack_Size), Loc);
-         end if;
+         Last_Stm := Last (S);
+         while Nkind (Last_Stm) in N_Pop_xxx_Label loop
+            Prev (Last_Stm);
+         end loop;
 
-         Sec_Stack_Len := Convert_To (RTE (RE_Storage_Offset), Sec_Stack_Len);
+         --  Now insert return unless last statement is a transfer
 
-         --  Build and set declarations for the wrapped thread body
+         if not Is_Transfer (Last_Stm) then
 
-         Ent_SS   :=
-           Make_Defining_Identifier (Loc,
-             Chars => Name_uSecondary_Stack);
-         Ent_ATSD :=
-           Make_Defining_Identifier (Loc,
-             Chars => Name_uProcess_ATSD);
+            --  The source location for the return is the end label of the
+            --  procedure if present. Otherwise use the sloc of the last
+            --  statement in the list. If the list comes from a generated
+            --  exception handler and we are not debugging generated code,
+            --  all the statements within the handler are made invisible
+            --  to the debugger.
 
-         Decl_SS :=
-           Make_Object_Declaration (Loc,
-             Defining_Identifier => Ent_SS,
-             Aliased_Present     => True,
-             Object_Definition   =>
-               Make_Subtype_Indication (Loc,
-                 Subtype_Mark =>
-                   New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
-                 Constraint   =>
-                   Make_Index_Or_Discriminant_Constraint (Loc,
-                     Constraints => New_List (
-                       Make_Range (Loc,
-                         Low_Bound  => Make_Integer_Literal (Loc, 1),
-                         High_Bound => Sec_Stack_Len)))));
-
-         Decl_ATSD :=
-           Make_Object_Declaration (Loc,
-             Defining_Identifier => Ent_ATSD,
-             Aliased_Present     => True,
-             Object_Definition   => New_Occurrence_Of (RTE (RE_ATSD), Loc));
-
-         Set_Declarations (N, New_List (Decl_SS, Decl_ATSD));
-         Analyze (Decl_SS);
-         Analyze (Decl_ATSD);
-         Set_Alignment (Ent_SS, UI_From_Int (Maximum_Alignment));
-
-         --  Create new exception handler
-
-         if Restriction_Active (No_Exception_Handlers) then
-            Excep_Handlers := No_List;
+            if Nkind (Parent (S)) = N_Exception_Handler
+              and then not Comes_From_Source (Parent (S))
+            then
+               Loc := Sloc (Last_Stm);
 
-         else
-            Check_Restriction (No_Exception_Handlers, N);
+            elsif Present (End_Label (H)) then
+               Loc := Sloc (End_Label (H));
 
-            Ent_EO :=
-              Make_Defining_Identifier (Loc,
-                Chars => Name_uE);
+            else
+               Loc := Sloc (Last_Stm);
+            end if;
 
-            Excep_Handlers := New_List (
-              Make_Implicit_Exception_Handler (Loc,
-                Choice_Parameter => Ent_EO,
-                Exception_Choices => New_List (
-                  Make_Others_Choice (Loc)),
-                Statements => New_List (
-                  Make_Procedure_Call_Statement (Loc,
-                    Name =>
-                      New_Occurrence_Of
-                        (RTE (RE_Thread_Body_Exceptional_Exit), Loc),
-                    Parameter_Associations => New_List (
-                      New_Occurrence_Of (Ent_EO, Loc))))));
+            Append_To (S, Make_Simple_Return_Statement (Loc));
          end if;
-
-         --  Now build new handled statement sequence and analyze it
-
-         Set_Handled_Statement_Sequence (N,
-           Make_Handled_Sequence_Of_Statements (Loc,
-             Statements => New_List (
-
-               Make_Procedure_Call_Statement (Loc,
-                 Name => New_Occurrence_Of (RTE (RE_Thread_Body_Enter), Loc),
-                 Parameter_Associations => New_List (
-
-                   Make_Attribute_Reference (Loc,
-                     Prefix => New_Occurrence_Of (Ent_SS, Loc),
-                     Attribute_Name => Name_Address),
-
-                   Make_Attribute_Reference (Loc,
-                     Prefix => New_Occurrence_Of (Ent_SS, Loc),
-                     Attribute_Name => Name_Length),
-
-                   Make_Attribute_Reference (Loc,
-                     Prefix => New_Occurrence_Of (Ent_ATSD, Loc),
-                     Attribute_Name => Name_Address))),
-
-               Make_Block_Statement (Loc,
-                 Declarations => User_Decls,
-                 Handled_Statement_Sequence => H),
-
-               Make_Procedure_Call_Statement (Loc,
-                 Name => New_Occurrence_Of (RTE (RE_Thread_Body_Leave), Loc))),
-
-             Exception_Handlers => Excep_Handlers));
-
-         Analyze (Handled_Statement_Sequence (N));
-         End_Scope;
-      end Expand_Thread_Body;
+      end Add_Return;
 
    --  Start of processing for Expand_N_Subprogram_Body
 
@@ -4171,7 +4045,45 @@ package body Exp_Ch6 is
       if Is_Non_Empty_List (Declarations (N)) then
          L := Declarations (N);
       else
-         L := Statements (Handled_Statement_Sequence (N));
+         L := Statements (H);
+      end if;
+
+      --  If local-exception-to-goto optimization active, insert dummy push
+      --  statements at start, and dummy pop statements at end.
+
+      if (Debug_Flag_Dot_G
+           or else Restriction_Active (No_Exception_Propagation))
+        and then Is_Non_Empty_List (L)
+      then
+         declare
+            FS  : constant Node_Id    := First (L);
+            FL  : constant Source_Ptr := Sloc (FS);
+            LS  : Node_Id;
+            LL  : Source_Ptr;
+
+         begin
+            --  LS points to either last statement, if statements are present
+            --  or to the last declaration if there are no statements present.
+            --  It is the node after which the pop's are generated.
+
+            if Is_Non_Empty_List (Statements (H)) then
+               LS := Last (Statements (H));
+            else
+               LS := Last (L);
+            end if;
+
+            LL := Sloc (LS);
+
+            Insert_List_Before_And_Analyze (FS, New_List (
+              Make_Push_Constraint_Error_Label (FL),
+              Make_Push_Program_Error_Label    (FL),
+              Make_Push_Storage_Error_Label    (FL)));
+
+            Insert_List_After_And_Analyze (LS, New_List (
+              Make_Pop_Constraint_Error_Label  (LL),
+              Make_Pop_Program_Error_Label     (LL),
+              Make_Pop_Storage_Error_Label     (LL)));
+         end;
       end if;
 
       --  Find entity for subprogram
@@ -4184,11 +4096,11 @@ package body Exp_Ch6 is
          Spec_Id := Body_Id;
       end if;
 
-      --  Need poll on entry to subprogram if polling enabled. We only
-      --  do this for non-empty subprograms, since it does not seem
-      --  necessary to poll for a dummy null subprogram. Do not add polling
-      --  point if calls to this subprogram will be inlined by the back-end,
-      --  to avoid repeated polling points in nested inlinings.
+      --  Need poll on entry to subprogram if polling enabled. We only do this
+      --  for non-empty subprograms, since it does not seem necessary to poll
+      --  for a dummy null subprogram. Do not add polling point if calls to
+      --  this subprogram will be inlined by the back-end, to avoid repeated
+      --  polling points in nested inlinings.
 
       if Is_Non_Empty_List (L) then
          if Is_Inlined (Spec_Id)
@@ -4281,7 +4193,8 @@ package body Exp_Ch6 is
       then
          Add_Discriminal_Declarations
            (Declarations (N), Scop, Name_uObject, Loc);
-         Add_Private_Declarations (Declarations (N), Scop, Name_uObject, Loc);
+         Add_Private_Declarations
+           (Declarations (N), Scop, Name_uObject, Loc);
 
          --  Associate privals and discriminals with the next protected
          --  operation body to be expanded. These are used to expand references
@@ -4393,7 +4306,7 @@ package body Exp_Ch6 is
               Make_Handled_Sequence_Of_Statements (Hloc,
                 Statements => New_List (Blok, Rais)));
 
-            New_Scope (Spec_Id);
+            Push_Scope (Spec_Id);
             Analyze (Blok);
             Analyze (Rais);
             Pop_Scope;
@@ -4442,12 +4355,6 @@ package body Exp_Ch6 is
          end;
       end if;
 
-      --  Deal with thread body
-
-      if Is_Thread_Body (Spec_Id) then
-         Expand_Thread_Body;
-      end if;
-
       --  Set to encode entity names in package body before gigi is called
 
       Qualify_Entity_Names (N);
@@ -4505,6 +4412,8 @@ package body Exp_Ch6 is
             --  The protected subprogram is declared outside of the protected
             --  body. Given that the body has frozen all entities so far, we
             --  analyze the subprogram and perform freezing actions explicitly.
+            --  including the generation of an explicit freeze node, to ensure
+            --  that gigi has the proper order of elaboration.
             --  If the body is a subunit, the insertion point is before the
             --  stub in the parent.
 
@@ -4516,10 +4425,11 @@ package body Exp_Ch6 is
 
             Insert_Before (Prot_Bod, Prot_Decl);
             Prot_Id := Defining_Unit_Name (Specification (Prot_Decl));
+            Set_Has_Delayed_Freeze (Prot_Id);
 
-            New_Scope (Scope (Scop));
+            Push_Scope (Scope (Scop));
             Analyze (Prot_Decl);
-            Create_Extra_Formals (Prot_Id);
+            Insert_Actions (N, Freeze_Entity (Prot_Id, Loc));
             Set_Protected_Body_Subprogram (Subp, Prot_Id);
             Pop_Scope;
          end if;
@@ -4650,7 +4560,7 @@ package body Exp_Ch6 is
                   New_Occurrence_Of (Param, Loc)));
 
             --  Analyze new actual. Other actuals in calls are already analyzed
-            --  and the list of actuals is not renalyzed after rewriting.
+            --  and the list of actuals is not reanalyzed after rewriting.
 
             Set_Parent (Rec, N);
             Analyze (Rec);
@@ -4747,6 +4657,13 @@ package body Exp_Ch6 is
          then
             return False;
 
+         --  If the return type is a limited interface it has to be treated
+         --  as a return in place, even if the actual object is some non-
+         --  limited descendant.
+
+         elsif Is_Limited_Interface (Etype (E)) then
+            return True;
+
          else
             return Is_Inherently_Limited_Type (Etype (E))
               and then Ada_Version >= Ada_05
@@ -4767,7 +4684,12 @@ package body Exp_Ch6 is
       Function_Id : Entity_Id;
 
    begin
-      if Nkind (Exp_Node) = N_Qualified_Expression then
+      --  Step past qualification or unchecked conversion (the latter can occur
+      --  in cases of calls to 'Input).
+
+      if Nkind_In
+           (Exp_Node, N_Qualified_Expression, N_Unchecked_Type_Conversion)
+      then
          Exp_Node := Expression (N);
       end if;
 
@@ -4792,8 +4714,8 @@ package body Exp_Ch6 is
 
    function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean is
    begin
-      if Nkind (N) = N_Return_Statement
-        or else Nkind (N) = N_Extended_Return_Statement
+      if Nkind_In (N, N_Simple_Return_Statement,
+                      N_Extended_Return_Statement)
       then
          return Is_Build_In_Place_Function
                   (Return_Applies_To (Return_Statement_Entity (N)));
@@ -4808,7 +4730,6 @@ package body Exp_Ch6 is
 
    procedure Freeze_Subprogram (N : Node_Id) is
       Loc : constant Source_Ptr := Sloc (N);
-      E   : constant Entity_Id  := Entity (N);
 
       procedure Register_Predefined_DT_Entry (Prim : Entity_Id);
       --  (Ada 2005): Register a predefined primitive in all the secondary
@@ -4822,6 +4743,7 @@ package body Exp_Ch6 is
          Iface_DT_Ptr : Elmt_Id;
          Tagged_Typ   : Entity_Id;
          Thunk_Id     : Entity_Id;
+         Thunk_Code   : Node_Id;
 
       begin
          Tagged_Typ := Find_Dispatching_Type (Prim);
@@ -4843,129 +4765,126 @@ package body Exp_Ch6 is
          Iface_DT_Ptr :=
            Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)));
 
-         while Present (Iface_DT_Ptr) loop
-            Thunk_Id :=
-              Make_Defining_Identifier (Loc,
-                Chars => New_Internal_Name ('T'));
+         while Present (Iface_DT_Ptr)
+            and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
+         loop
+            pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
+            Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
+
+            if Present (Thunk_Code) then
+               Insert_Actions_After (N, New_List (
+                 Thunk_Code,
+
+                 Build_Set_Predefined_Prim_Op_Address (Loc,
+                   Tag_Node => New_Reference_To (Node (Iface_DT_Ptr), Loc),
+                   Position => DT_Position (Prim),
+                   Address_Node =>
+                     Make_Attribute_Reference (Loc,
+                       Prefix         => New_Reference_To (Thunk_Id, Loc),
+                       Attribute_Name => Name_Address)),
+
+                 Build_Set_Predefined_Prim_Op_Address (Loc,
+                   Tag_Node => New_Reference_To
+                                 (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
+                   Position => DT_Position (Prim),
+                   Address_Node =>
+                     Make_Attribute_Reference (Loc,
+                       Prefix         => New_Reference_To (Prim, Loc),
+                       Attribute_Name => Name_Address))));
+            end if;
 
-            Insert_Actions (N, New_List (
-              Expand_Interface_Thunk
-               (N           => Prim,
-                Thunk_Alias => Prim,
-                Thunk_Id    => Thunk_Id),
-
-              Build_Set_Predefined_Prim_Op_Address (Loc,
-                Tag_Node =>
-                  New_Reference_To (Node (Iface_DT_Ptr), Loc),
-                Position_Node =>
-                  Make_Integer_Literal (Loc, DT_Position (Prim)),
-                Address_Node =>
-                  Make_Attribute_Reference (Loc,
-                    Prefix         => New_Reference_To (Thunk_Id, Loc),
-                    Attribute_Name => Name_Address))));
+            Next_Elmt (Iface_DT_Ptr);
+            pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
 
             Next_Elmt (Iface_DT_Ptr);
          end loop;
       end Register_Predefined_DT_Entry;
 
-   --  Start of processing for Freeze_Subprogram
+      --  Local variables
 
-   begin
-      --  We assume that imported CPP primitives correspond with objects
-      --  whose constructor is in the CPP side (and therefore we don't need
-      --  to generate code to register them in the dispatch table).
+      Subp : constant Entity_Id := Entity (N);
 
-      if Is_Imported (E)
-        and then Convention (E) = Convention_CPP
-      then
-         return;
-      end if;
+   --  Start of processing for Freeze_Subprogram
 
-      --  When a primitive is frozen, enter its name in the corresponding
-      --  dispatch table. If the DTC_Entity field is not set this is an
-      --  overridden primitive that can be ignored. We suppress the
-      --  initialization of the dispatch table entry when Java_VM because
-      --  the dispatching mechanism is handled internally by the JVM.
-
-      if Is_Dispatching_Operation (E)
-        and then not Is_Abstract_Subprogram (E)
-        and then Present (DTC_Entity (E))
-        and then not Java_VM
-        and then not Is_CPP_Class (Scope (DTC_Entity (E)))
+   begin
+      --  We suppress the initialization of the dispatch table entry when
+      --  VM_Target because the dispatching mechanism is handled internally
+      --  by the VM.
+
+      if Is_Dispatching_Operation (Subp)
+        and then not Is_Abstract_Subprogram (Subp)
+        and then Present (DTC_Entity (Subp))
+        and then Present (Scope (DTC_Entity (Subp)))
+        and then VM_Target = No_VM
+        and then not Restriction_Active (No_Dispatching_Calls)
+        and then RTE_Available (RE_Tag)
       then
-         Check_Overriding_Operation (E);
-
-         --  Ada 95 case: Register the subprogram in the primary dispatch table
-
-         --  Do not register the subprogram in the dispatch table if we are
-         --  compiling under No_Dispatching_Calls restriction.
-
-         if not Restriction_Active (No_Dispatching_Calls) then
-
-            if Ada_Version < Ada_05 then
-               Insert_After (N,
-                 Fill_DT_Entry (Sloc (N), Prim => E));
-
-            --  Ada 2005 case: Register the subprogram in all the dispatch
-            --  tables associated with the type
+         declare
+            Typ : constant Entity_Id := Scope (DTC_Entity (Subp));
 
-            else
-               declare
-                  Typ : constant Entity_Id := Scope (DTC_Entity (E));
+         begin
+            --  Handle private overriden primitives
 
-               begin
-                  if not Is_Interface (Typ)
-                    and then Is_Predefined_Dispatching_Operation (E)
-                  then
-                     Register_Predefined_DT_Entry (E);
-                     Insert_After (N, Fill_DT_Entry (Sloc (N), Prim => E));
+            if not Is_CPP_Class (Typ) then
+               Check_Overriding_Operation (Subp);
+            end if;
 
-                  --  There is no dispatch table associated with abstract
-                  --  interface types. Each type implementing interfaces will
-                  --  fill the associated secondary DT entries.
+            --  We assume that imported CPP primitives correspond with objects
+            --  whose constructor is in the CPP side; therefore we don't need
+            --  to generate code to register them in the dispatch table.
 
-                  elsif not Is_Interface (Typ)
-                    or else Present (Alias (E))
-                  then
-                     --  Ada 2005 (AI-251): Check if this entry corresponds
-                     --  with a subprogram that covers an abstract interface
-                     --  type.
+            if Is_CPP_Class (Typ) then
+               null;
 
-                     if Present (Abstract_Interface_Alias (E)) then
-                        Register_Interface_DT_Entry (N, E);
+            --  Handle CPP primitives found in derivations of CPP_Class types.
+            --  These primitives must have been inherited from some parent, and
+            --  there is no need to register them in the dispatch table because
+            --  Build_Inherit_Prims takes care of the initialization of these
+            --  slots.
 
-                     --  Common case: Primitive subprogram
+            elsif Is_Imported (Subp)
+                    and then (Convention (Subp) = Convention_CPP
+                                or else Convention (Subp) = Convention_C)
+            then
+               null;
 
-                     else
-                        --  Generate thunks for all the predefined operations
+            --  Generate code to register the primitive in non statically
+            --  allocated dispatch tables
 
-                        if Is_Predefined_Dispatching_Operation (E) then
-                           Register_Predefined_DT_Entry (E);
-                        end if;
+            elsif not Static_Dispatch_Tables
+              or else not
+                Is_Library_Level_Tagged_Type (Scope (DTC_Entity (Subp)))
+            then
+               --  When a primitive is frozen, enter its name in its dispatch
+               --  table slot.
 
-                        Insert_After (N,
-                          Fill_DT_Entry (Sloc (N), Prim => E));
-                     end if;
+               if not Is_Interface (Typ)
+                 or else Present (Abstract_Interface_Alias (Subp))
+               then
+                  if Is_Predefined_Dispatching_Operation (Subp) then
+                     Register_Predefined_DT_Entry (Subp);
                   end if;
-               end;
+
+                  Register_Primitive (Loc,
+                    Prim    => Subp,
+                    Ins_Nod => N);
+               end if;
             end if;
-         end if;
+         end;
       end if;
 
-      --  Mark functions that return by reference. Note that it cannot be
-      --  part of the normal semantic analysis of the spec since the
-      --  underlying returned type may not be known yet (for private types).
+      --  Mark functions that return by reference. Note that it cannot be part
+      --  of the normal semantic analysis of the spec since the underlying
+      --  returned type may not be known yet (for private types).
 
       declare
-         Typ  : constant Entity_Id := Etype (E);
+         Typ  : constant Entity_Id := Etype (Subp);
          Utyp : constant Entity_Id := Underlying_Type (Typ);
-
       begin
          if Is_Inherently_Limited_Type (Typ) then
-            Set_Returns_By_Ref (E);
-
+            Set_Returns_By_Ref (Subp);
          elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
-            Set_Returns_By_Ref (E);
+            Set_Returns_By_Ref (Subp);
          end if;
       end;
    end Freeze_Subprogram;
@@ -4987,10 +4906,28 @@ package body Exp_Ch6 is
       Return_Obj_Access : Entity_Id;
 
    begin
-      if Nkind (Func_Call) = N_Qualified_Expression then
+      --  Step past qualification or unchecked conversion (the latter can occur
+      --  in cases of calls to 'Input).
+
+      if Nkind_In (Func_Call,
+                   N_Qualified_Expression,
+                   N_Unchecked_Type_Conversion)
+      then
          Func_Call := Expression (Func_Call);
       end if;
 
+      --  If the call has already been processed to add build-in-place actuals
+      --  then return. This should not normally occur in an allocator context,
+      --  but we add the protection as a defensive measure.
+
+      if Is_Expanded_Build_In_Place_Call (Func_Call) then
+         return;
+      end if;
+
+      --  Mark the call as processed as a build-in-place call
+
+      Set_Is_Expanded_Build_In_Place_Call (Func_Call);
+
       Loc := Sloc (Function_Call);
 
       if Is_Entity_Name (Name (Func_Call)) then
@@ -5009,7 +4946,12 @@ package body Exp_Ch6 is
       --  allocated on the caller side, and access to it is passed to the
       --  function.
 
-      if Is_Constrained (Result_Subt) then
+      --  Here and in related routines, we must examine the full view of the
+      --  type, because the view at the point of call may differ from that
+      --  that in the function body, and the expansion mechanism depends on
+      --  the characteristics of the full view.
+
+      if Is_Constrained (Underlying_Type (Result_Subt)) then
 
          --  Replace the initialized allocator of form "new T'(Func (...))"
          --  with an uninitialized allocator of form "new T", where T is the
@@ -5038,14 +4980,26 @@ package body Exp_Ch6 is
              Object_Definition   => New_Reference_To (Acc_Type, Loc),
              Expression          => Relocate_Node (Allocator)));
 
+         --  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_Alloc_Form_Actual_To_Build_In_Place_Call
+           (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
+
+         Add_Final_List_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_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
-         Add_Task_Actuals_To_Build_In_Place_Call
-           (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type));
          Add_Access_Actual_To_Build_In_Place_Call
            (Func_Call,
             Function_Id,
@@ -5063,18 +5017,22 @@ package body Exp_Ch6 is
       --  operations. ???
 
       else
+
          --  Pass an allocation parameter indicating that the function should
          --  allocate its result on the heap.
 
          Add_Alloc_Form_Actual_To_Build_In_Place_Call
            (Func_Call, Function_Id, Alloc_Form => Global_Heap);
 
-         --  The caller does not provide the return object in this case, so we
-         --  have to pass null for the object access actual.
+         Add_Final_List_Actual_To_Build_In_Place_Call
+           (Func_Call, Function_Id, Acc_Type);
 
-         Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
          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);
       end if;
@@ -5102,10 +5060,29 @@ package body Exp_Ch6 is
       Return_Obj_Decl : Entity_Id;
 
    begin
-      if Nkind (Func_Call) = N_Qualified_Expression then
+      --  Step past qualification or unchecked conversion (the latter can occur
+      --  in cases of calls to 'Input).
+
+      if Nkind_In (Func_Call, N_Qualified_Expression,
+                              N_Unchecked_Type_Conversion)
+      then
          Func_Call := Expression (Func_Call);
       end if;
 
+      --  If the call has already been processed to add build-in-place actuals
+      --  then return. One place this can occur is for calls to build-in-place
+      --  functions that occur within a call to a protected operation, where
+      --  due to rewriting and expansion of the protected call there can be
+      --  more than one call to Expand_Actuals for the same set of actuals.
+
+      if Is_Expanded_Build_In_Place_Call (Func_Call) then
+         return;
+      end if;
+
+      --  Mark the call as processed as a build-in-place call
+
+      Set_Is_Expanded_Build_In_Place_Call (Func_Call);
+
       Loc := Sloc (Function_Call);
 
       if Is_Entity_Name (Name (Func_Call)) then
@@ -5123,7 +5100,7 @@ package body Exp_Ch6 is
       --  When the result subtype is constrained, an object of the subtype is
       --  declared and an access value designating it is passed as an actual.
 
-      if Is_Constrained (Result_Subt) then
+      if Is_Constrained (Underlying_Type (Result_Subt)) then
 
          --  Create a temporary object to hold the function result
 
@@ -5142,12 +5119,24 @@ package body Exp_Ch6 is
 
          Insert_Action (Func_Call, Return_Obj_Decl);
 
-         --  Add an implicit actual to the function call that provides access
-         --  to the caller's 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_Alloc_Form_Actual_To_Build_In_Place_Call
+           (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
+
+         Add_Final_List_Actual_To_Build_In_Place_Call
+           (Func_Call, Function_Id, Acc_Type => Empty);
 
-         Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
          Add_Task_Actuals_To_Build_In_Place_Call
            (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
+
+         --  Add an implicit actual to the function call that provides access
+         --  to the caller's return object.
+
          Add_Access_Actual_To_Build_In_Place_Call
            (Func_Call, Function_Id, New_Reference_To (Return_Obj_Id, Loc));
 
@@ -5157,18 +5146,22 @@ package body Exp_Ch6 is
       --  scope is established to ensure eventual cleanup of the result.
 
       else
+
          --  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
            (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
 
-         --  Pass a null value to the function since no return object is
-         --  available on the caller side.
+         Add_Final_List_Actual_To_Build_In_Place_Call
+           (Func_Call, Function_Id, Acc_Type => Empty);
 
-         Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
          Add_Task_Actuals_To_Build_In_Place_Call
            (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
+
+         --  Pass a null value to the function since no return object is
+         --  available on the caller side.
+
          Add_Access_Actual_To_Build_In_Place_Call
            (Func_Call, Function_Id, Empty);
 
@@ -5195,10 +5188,27 @@ package body Exp_Ch6 is
       New_Expr        : Node_Id;
 
    begin
-      if Nkind (Func_Call) = N_Qualified_Expression then
+      --  Step past qualification or unchecked conversion (the latter can occur
+      --  in cases of calls to 'Input).
+
+      if Nkind_In (Func_Call, N_Qualified_Expression,
+                              N_Unchecked_Type_Conversion)
+      then
          Func_Call := Expression (Func_Call);
       end if;
 
+      --  If the call has already been processed to add build-in-place actuals
+      --  then return. This should not normally occur in an assignment context,
+      --  but we add the protection as a defensive measure.
+
+      if Is_Expanded_Build_In_Place_Call (Func_Call) then
+         return;
+      end if;
+
+      --  Mark the call as processed as a build-in-place call
+
+      Set_Is_Expanded_Build_In_Place_Call (Func_Call);
+
       Loc := Sloc (Function_Call);
 
       if Is_Entity_Name (Name (Func_Call)) then
@@ -5215,18 +5225,22 @@ package body Exp_Ch6 is
 
       --  When the result subtype is unconstrained, an additional actual must
       --  be passed to indicate that the caller is providing the return object.
+      --  This parameter must also be passed when the called function has a
+      --  controlling result, because dispatching calls to the function needs
+      --  to be treated effectively the same as calls to class-wide functions.
 
-      if not Is_Constrained (Result_Subt) then
-         Add_Alloc_Form_Actual_To_Build_In_Place_Call
-           (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
-      end if;
+      Add_Alloc_Form_Actual_To_Build_In_Place_Call
+        (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
 
-      --  Add an implicit actual to the function call that provides access to
-      --  the caller's return object.
+      Add_Final_List_Actual_To_Build_In_Place_Call
+        (Func_Call, Function_Id, Acc_Type => Empty);
 
-      Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
       Add_Task_Actuals_To_Build_In_Place_Call
         (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
+
+      --  Add an implicit actual to the function call that provides access to
+      --  the caller's return object.
+
       Add_Access_Actual_To_Build_In_Place_Call
         (Func_Call,
          Function_Id,
@@ -5282,6 +5296,7 @@ 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;
@@ -5295,10 +5310,27 @@ package body Exp_Ch6 is
       Pass_Caller_Acc : Boolean := False;
 
    begin
-      if Nkind (Func_Call) = N_Qualified_Expression then
+      --  Step past qualification or unchecked conversion (the latter can occur
+      --  in cases of calls to 'Input).
+
+      if Nkind_In (Func_Call, N_Qualified_Expression,
+                              N_Unchecked_Type_Conversion)
+      then
          Func_Call := Expression (Func_Call);
       end if;
 
+      --  If the call has already been processed to add build-in-place actuals
+      --  then return. This should not normally occur in an object declaration,
+      --  but we add the protection as a defensive measure.
+
+      if Is_Expanded_Build_In_Place_Call (Func_Call) then
+         return;
+      end if;
+
+      --  Mark the call as processed as a build-in-place call
+
+      Set_Is_Expanded_Build_In_Place_Call (Func_Call);
+
       Loc := Sloc (Function_Call);
 
       if Is_Entity_Name (Name (Func_Call)) then
@@ -5318,12 +5350,21 @@ package body Exp_Ch6 is
       --  to the (specific) result type of the function is inserted to handle
       --  the case where the object is declared with a class-wide type.
 
-      if Is_Constrained (Result_Subt) then
+      if Is_Constrained (Underlying_Type (Result_Subt)) then
          Caller_Object :=
             Make_Unchecked_Type_Conversion (Loc,
               Subtype_Mark => New_Reference_To (Result_Subt, Loc),
               Expression   => New_Reference_To (Obj_Def_Id, Loc));
 
+         --  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_Alloc_Form_Actual_To_Build_In_Place_Call
+           (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
+
       --  If the function's result subtype is unconstrained and the object is
       --  a return object of an enclosing build-in-place function, then the
       --  implicit build-in-place parameters of the enclosing function must be
@@ -5343,7 +5384,7 @@ package body Exp_Ch6 is
 
          --  Otherwise, when the enclosing function has an unconstrained result
          --  type, the BIP_Alloc_Form formal of the enclosing function must be
-         --  passed long to the callee.
+         --  passed along to the callee.
 
          else
             Add_Alloc_Form_Actual_To_Build_In_Place_Call
@@ -5385,22 +5426,28 @@ package body Exp_Ch6 is
          Establish_Transient_Scope (Object_Decl, Sec_Stack => True);
       end if;
 
-      Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
+      Add_Final_List_Actual_To_Build_In_Place_Call
+        (Func_Call, Function_Id, Acc_Type => Empty);
+
       if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement
         and then Has_Task (Result_Subt)
       then
          Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id);
+
+         --  Here we're passing along the master that was passed in to this
+         --  function.
+
          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));
-         --  Here we're passing along the master that was passed in to this
-         --  function.
+
       else
          Add_Task_Actuals_To_Build_In_Place_Call
            (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
       end if;
+
       Add_Access_Actual_To_Build_In_Place_Call
         (Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc);
 
@@ -5425,7 +5472,7 @@ package body Exp_Ch6 is
       --  the object declaration is rewritten to be a renaming of a dereference
       --  of the access object.
 
-      if Is_Constrained (Result_Subt) then
+      if Is_Constrained (Underlying_Type (Result_Subt)) then
          Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl);
       else
          Insert_Before_And_Analyze (Object_Decl, Ptr_Typ_Decl);
@@ -5449,7 +5496,7 @@ package body Exp_Ch6 is
           Object_Definition   => New_Reference_To (Ref_Type, Loc),
           Expression          => New_Expr));
 
-      if Is_Constrained (Result_Subt) then
+      if Is_Constrained (Underlying_Type (Result_Subt)) then
          Set_Expression (Object_Decl, Empty);
          Set_No_Initialization (Object_Decl);
 
@@ -5482,10 +5529,26 @@ package body Exp_Ch6 is
          --  ensure the correct replacement of the object declaration by the
          --  object renaming declaration to avoid homograph conflicts (since
          --  the object declaration's defining identifier was already entered
-         --  in current scope).
+         --  in current scope). The Next_Entity links of the two entities also
+         --  have to be swapped since the entities are part of the return
+         --  scope's entity list and the list structure would otherwise be
+         --  corrupted.
+
+         declare
+            Renaming_Def_Id  : constant Entity_Id :=
+                                 Defining_Identifier (Object_Decl);
+            Next_Entity_Temp : constant Entity_Id :=
+                                 Next_Entity (Renaming_Def_Id);
+         begin
+            Set_Chars (Renaming_Def_Id, Chars (Obj_Def_Id));
+
+            --  Swap next entity links in preparation for exchanging entities
 
-         Set_Chars (Defining_Identifier (Object_Decl), Chars (Obj_Def_Id));
-         Exchange_Entities (Defining_Identifier (Object_Decl), Obj_Def_Id);
+            Set_Next_Entity (Renaming_Def_Id, Next_Entity (Obj_Def_Id));
+            Set_Next_Entity (Obj_Def_Id, Next_Entity_Temp);
+
+            Exchange_Entities (Renaming_Def_Id, Obj_Def_Id);
+         end;
       end if;
 
       --  If the object entity has a class-wide Etype, then we need to change
@@ -5501,51 +5564,4 @@ package body Exp_Ch6 is
       end if;
    end Make_Build_In_Place_Call_In_Object_Declaration;
 
-   ---------------------------------
-   -- Register_Interface_DT_Entry --
-   ---------------------------------
-
-   procedure Register_Interface_DT_Entry
-     (Related_Nod : Node_Id;
-      Prim        : Entity_Id)
-   is
-      Loc        : constant Source_Ptr := Sloc (Prim);
-      Iface_Typ  : Entity_Id;
-      Tagged_Typ : Entity_Id;
-      Thunk_Id   : Entity_Id;
-
-   begin
-      --  Nothing to do if the run-time does not support abstract interfaces
-
-      if not (RTE_Available (RE_Interface_Tag)) then
-         return;
-      end if;
-
-      Tagged_Typ := Find_Dispatching_Type (Alias (Prim));
-      Iface_Typ  := Find_Dispatching_Type (Abstract_Interface_Alias (Prim));
-
-      --  Generate the code of the thunk only if the abstract interface type is
-      --  not an immediate ancestor of Tagged_Type; otherwise the dispatch
-      --  table associated with the interface is the primary dispatch table.
-
-      pragma Assert (Is_Interface (Iface_Typ));
-
-      if not Is_Parent (Iface_Typ, Tagged_Typ) then
-         Thunk_Id  :=
-           Make_Defining_Identifier (Loc,
-             Chars => New_Internal_Name ('T'));
-
-         Insert_Actions (Related_Nod, New_List (
-           Expand_Interface_Thunk
-             (N           => Prim,
-              Thunk_Alias => Alias (Prim),
-              Thunk_Id    => Thunk_Id),
-
-           Fill_Secondary_DT_Entry (Sloc (Prim),
-             Prim         => Prim,
-             Iface_DT_Ptr => Find_Interface_ADT (Tagged_Typ, Iface_Typ),
-             Thunk_Id     => Thunk_Id)));
-      end if;
-   end Register_Interface_DT_Entry;
-
 end Exp_Ch6;