2011-08-29 Robert Dewar <dewar@adacore.com>

	* a-exexpr-gcc.adb, a-synbar.adb, sem_ch13.adb: Minor reformatting.

2011-08-29  Bob Duff  <duff@adacore.com>

	* sem_aggr.adb (Resolve_Aggr_Expr): Call this routine even in the case
	of <>, because this is the routine that checks for dimensionality
	errors (for example, for a two-dimensional array, (others => <>) should
	be (others => (others => <>)).

2011-08-29  Hristian Kirtchev  <kirtchev@adacore.com>

	* impunit.adb: Add new run-time units.
	* freeze.adb, exp_ch7.ads, exp_ch7.adb, exp_util.ads, exp_util.adb,
	s-stposu.ads, s-stposu.adb: Code clean up.
	Handle protected class-wide or task class-wide types
	Handle C/C++/CIL/Java types.
	* s-spsufi.adb, s-spsufi.ads: New files.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178205 138bc75d-0d04-0410-961f-82ee72b054a4

21 files changed, 886 insertions, 472 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index ba9fcbe5f7a..75f4d4e7d05 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,23 @@
+2011-08-29  Robert Dewar  <dewar@adacore.com>
+
+	* a-exexpr-gcc.adb, a-synbar.adb, sem_ch13.adb: Minor reformatting.
+
+2011-08-29  Bob Duff  <duff@adacore.com>
+
+	* sem_aggr.adb (Resolve_Aggr_Expr): Call this routine even in the case
+	of <>, because this is the routine that checks for dimensionality
+	errors (for example, for a two-dimensional array, (others => <>) should
+	be (others => (others => <>)).
+
+2011-08-29  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* impunit.adb: Add new run-time units.
+	* freeze.adb, exp_ch7.ads, exp_ch7.adb, exp_util.ads, exp_util.adb,
+	s-stposu.ads, s-stposu.adb: Code clean up.
+	Handle protected class-wide or task class-wide types
+	Handle C/C++/CIL/Java types.
+	* s-spsufi.adb, s-spsufi.ads: New files.
+
 2011-08-29  Yannick Moy  <moy@adacore.com>
 
 	* sem_ch13.adb (Analyze_Aspect_Specifications): Reject test-case on
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index 86eb6a5cb6f..683c15aa732 100644
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -155,7 +155,6 @@ GNATRTL_NONTASKING_OBJS= \
   a-envvar$(objext) \
   a-except$(objext) \
   a-exctra$(objext) \
-  a-fihema$(objext) \
   a-finali$(objext) \
   a-flteio$(objext) \
   a-fwteio$(objext) \
@@ -291,6 +290,7 @@ GNATRTL_NONTASKING_OBJS= \
   a-tiunio$(objext) \
   a-unccon$(objext) \
   a-uncdea$(objext) \
+  a-undesu$(objext) \
   a-wichha$(objext) \
   a-wichun$(objext) \
   a-widcha$(objext) \
@@ -496,6 +496,7 @@ GNATRTL_NONTASKING_OBJS= \
   s-ficobl$(objext) \
   s-fileio$(objext) \
   s-filofl$(objext) \
+  s-finmas$(objext) \
   s-finroo$(objext) \
   s-fishfl$(objext) \
   s-flocon$(objext) \
@@ -606,12 +607,14 @@ GNATRTL_NONTASKING_OBJS= \
   s-sequio$(objext) \
   s-shasto$(objext) \
   s-soflin$(objext) \
+  s-spsufi$(objext) \
   s-stache$(objext) \
   s-stalib$(objext) \
   s-stausa$(objext) \
   s-stchop$(objext) \
   s-stoele$(objext) \
   s-stopoo$(objext) \
+  s-stposu$(objext) \
   s-stratt$(objext) \
   s-strhas$(objext) \
   s-string$(objext) \
diff --git a/gcc/ada/a-exexpr-gcc.adb b/gcc/ada/a-exexpr-gcc.adb
index d32e7a43805..66163dbb85b 100644
--- a/gcc/ada/a-exexpr-gcc.adb
+++ b/gcc/ada/a-exexpr-gcc.adb
@@ -277,13 +277,15 @@ package body Exception_Propagation is
 
    procedure GNAT_GCC_Exception_Cleanup
      (Reason : Unwind_Reason_Code;
-      Excep  : not null GNAT_GCC_Exception_Access) is
+      Excep  : not null GNAT_GCC_Exception_Access)
+   is
       pragma Unreferenced (Reason);
 
       procedure Free is new Unchecked_Deallocation
         (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
 
       Copy : GNAT_GCC_Exception_Access := Excep;
+
    begin
       --  Simply free the memory
 
@@ -303,6 +305,7 @@ package body Exception_Propagation is
       UW_Argument  : System.Address) return Unwind_Reason_Code
    is
       pragma Unreferenced (UW_Version, UW_Eclass, UW_Context, UW_Argument);
+
    begin
       --  Terminate when the end of the stack is reached
 
@@ -332,6 +335,7 @@ package body Exception_Propagation is
       Reraised : Boolean := False)
    is
       pragma Unreferenced (Excep, Current, Reraised);
+
    begin
       --  In the GNAT-SJLJ case this "stack" only exists implicitly, by way of
       --  local occurrence declarations together with save/restore operations
@@ -345,8 +349,10 @@ package body Exception_Propagation is
    -------------------------
 
    procedure Setup_Current_Excep
-     (GCC_Exception : not null GCC_Exception_Access) is
+     (GCC_Exception : not null GCC_Exception_Access)
+   is
       Excep : constant EOA := Get_Current_Excep.all;
+
    begin
       --  Setup the exception occurrence
 
@@ -356,7 +362,7 @@ package body Exception_Propagation is
 
          declare
             GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
-              To_GNAT_GCC_Exception (GCC_Exception);
+                                To_GNAT_GCC_Exception (GCC_Exception);
          begin
             Excep.all := GNAT_Occurrence.Occurrence;
          end;
@@ -404,7 +410,8 @@ package body Exception_Propagation is
    -----------------------------
 
    procedure Reraise_GCC_Exception
-     (GCC_Exception : not null GCC_Exception_Access) is
+     (GCC_Exception : not null GCC_Exception_Access)
+   is
    begin
       --  Simply propagate it
       Propagate_GCC_Exception (GCC_Exception);
@@ -418,7 +425,8 @@ package body Exception_Propagation is
    --  the two phase scheme it implements.
 
    procedure Propagate_GCC_Exception
-     (GCC_Exception : not null GCC_Exception_Access) is
+     (GCC_Exception : not null GCC_Exception_Access)
+   is
    begin
       --  Perform a standard raise first. If a regular handler is found, it
       --  will be entered after all the intermediate cleanups have run. If
@@ -436,15 +444,15 @@ package body Exception_Propagation is
 
       --  Now, un a forced unwind to trigger cleanups. Control should not
       --  resume there, if there are cleanups and in any cases as the
-      --  unwinding hook calls Unhandled_Exception_Terminate when end of stack
-      --  is reached.
+      --  unwinding hook calls Unhandled_Exception_Terminate when end of
+      --  stack is reached.
 
       Unwind_ForcedUnwind (GCC_Exception,
                            CleanupUnwind_Handler'Address,
                            System.Null_Address);
 
-      --  We get here in case of error.
-      --  The debugger has been notified before the second step above.
+      --  We get here in case of error. The debugger has been notified before
+      --  the second step above.
 
       Setup_Current_Excep (GCC_Exception);
       Unhandled_Exception_Terminate;
@@ -455,8 +463,8 @@ package body Exception_Propagation is
    -------------------------
 
    --  Build an object suitable for the libgcc processing and call
-   --  Unwind_RaiseException to actually throw, taking care of handling
-   --  the two phase scheme it implements.
+   --  Unwind_RaiseException to actually do the raise, taking care of
+   --  handling the two phase scheme it implements.
 
    procedure Propagate_Exception
      (E                   : Exception_Id;
@@ -494,14 +502,16 @@ package body Exception_Propagation is
 
       --  Allocate the GCC exception
 
-      GCC_Exception := new GNAT_GCC_Exception'
-        (Header    => (Class => GNAT_Exception_Class,
-                       Cleanup => GNAT_GCC_Exception_Cleanup'Address,
-                       Private1 => 0,
-                       Private2 => 0),
-         Occurrence => Excep.all);
+      GCC_Exception :=
+        new GNAT_GCC_Exception'
+          (Header     => (Class => GNAT_Exception_Class,
+                          Cleanup => GNAT_GCC_Exception_Cleanup'Address,
+                          Private1 => 0,
+                          Private2 => 0),
+           Occurrence => Excep.all);
+
+      --  Propagate it
 
-      --  Propagate it.
       Propagate_GCC_Exception (To_GCC_Exception (GCC_Exception));
    end Propagate_Exception;
 
diff --git a/gcc/ada/a-synbar.adb b/gcc/ada/a-synbar.adb
index 35a53aab696..33bb3e478c7 100644
--- a/gcc/ada/a-synbar.adb
+++ b/gcc/ada/a-synbar.adb
@@ -61,7 +61,6 @@ package body Ada.Synchronous_Barriers is
 
          Notified := Wait'Count = 0;
       end Wait;
-
    end Synchronous_Barrier;
 
    ----------------------
diff --git a/gcc/ada/a-undesu.adb b/gcc/ada/a-undesu.adb
index 97c79157a8f..14c60aac50b 100644
--- a/gcc/ada/a-undesu.adb
+++ b/gcc/ada/a-undesu.adb
@@ -17,20 +17,15 @@
 
 --  ??? What is the header version here, see a-uncdea.adb. No GPL?
 
-with System.Storage_Pools.Subpools; use System.Storage_Pools.Subpools;
+with System.Storage_Pools.Subpools,
+     System.Storage_Pools.Subpools.Finalization;
+
+use System.Storage_Pools.Subpools,
+    System.Storage_Pools.Subpools.Finalization;
 
 procedure Ada.Unchecked_Deallocate_Subpool
   (Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle)
 is
 begin
-   --  Finalize all controlled objects allocated on the input subpool
-
-   --  ??? It is awkward to create a child of Storage_Pools.Subpools for the
-   --  sole purpose of exporting Finalize_Subpool.
-
---   Finalize_Subpool (Subpool);
-
-   --  Dispatch to the user-defined implementation of Deallocate_Subpool
-
-   Deallocate_Subpool (Pool_Of_Subpool (Subpool).all, Subpool);
+   Finalize_And_Deallocate (Subpool);
 end Ada.Unchecked_Deallocate_Subpool;
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 2ba20e5565f..a22f86dff88 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6626,35 +6626,31 @@ package body Exp_Ch3 is
             --  finalization support if not needed.
 
             if not Comes_From_Source (Def_Id)
-               and then not Has_Private_Declaration (Def_Id)
+              and then not Has_Private_Declaration (Def_Id)
             then
                null;
 
-            elsif (Needs_Finalization (Desig_Type)
-                    and then Convention (Desig_Type) /= Convention_Java
-                    and then Convention (Desig_Type) /= Convention_CIL)
-              or else
-                (Is_Incomplete_Or_Private_Type (Desig_Type)
-                  and then No (Full_View (Desig_Type))
-
-                  --  An exception is made for types defined in the run-time
-                  --  because Ada.Tags.Tag itself is such a type and cannot
-                  --  afford this unnecessary overhead that would generates a
-                  --  loop in the expansion scheme...
-
-                   and then not In_Runtime (Def_Id)
-
-                  --  Another exception is if Restrictions (No_Finalization)
-                  --  is active, since then we know nothing is controlled.
+            --  An exception is made for types defined in the run-time because
+            --  Ada.Tags.Tag itself is such a type and cannot afford this
+            --  unnecessary overhead that would generates a loop in the
+            --  expansion scheme. Another exception is if Restrictions
+            --  (No_Finalization) is active, since then we know nothing is
+            --  controlled.
 
-                   and then not Restriction_Active (No_Finalization))
+            elsif Restriction_Active (No_Finalization)
+              or else In_Runtime (Def_Id)
+            then
+               null;
 
-               --  If the designated type is not frozen yet, its controlled
-               --  status must be retrieved explicitly.
+            --  The machinery assumes that incomplete or private types are
+            --  always completed by a controlled full vies.
 
+            elsif Needs_Finalization (Desig_Type)
+              or else
+                (Is_Incomplete_Or_Private_Type (Desig_Type)
+                  and then No (Full_View (Desig_Type)))
               or else
                 (Is_Array_Type (Desig_Type)
-                  and then not Is_Frozen (Desig_Type)
                   and then Needs_Finalization (Component_Type (Desig_Type)))
             then
                Build_Finalization_Master (Def_Id);
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index a4ef03ed6ce..3c42b646730 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -91,12 +91,13 @@ package body Exp_Ch4 is
    --  If a boolean array assignment can be done in place, build call to
    --  corresponding library procedure.
 
-   procedure Complete_Controlled_Allocation (Temp_Decl : Node_Id);
-   --  Subsidiary to Expand_N_Allocator and Expand_Allocator_Expression. Formal
-   --  Temp_Decl is the declaration of a temporary which hold the value of the
-   --  original allocator. Create a custom Allocate routine for the expression
-   --  of Temp_Decl. The routine does special processing for anonymous access
-   --  types.
+   function Current_Unit_First_Declaration return Node_Id;
+   --  Return the current unit's first declaration. If the declaration list is
+   --  empty, the routine generates a null statement and returns it.
+
+   function Current_Unit_Scope return Entity_Id;
+   --  Return the scope of the current unit. If the current unit is a body,
+   --  return the scope of the spec.
 
    procedure Displace_Allocator_Pointer (N : Node_Id);
    --  Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
@@ -375,121 +376,78 @@ package body Exp_Ch4 is
    end Build_Boolean_Array_Proc_Call;
 
    ------------------------------------
-   -- Complete_Controlled_Allocation --
+   -- Current_Unit_First_Declaration --
    ------------------------------------
 
-   procedure Complete_Controlled_Allocation (Temp_Decl : Node_Id) is
-      pragma Assert (Nkind (Temp_Decl) = N_Object_Declaration);
-
-      Ptr_Typ : constant Entity_Id := Etype (Defining_Identifier (Temp_Decl));
+   function Current_Unit_First_Declaration return Node_Id is
+      Sem_U : Node_Id := Unit (Cunit (Current_Sem_Unit));
+      Decl  : Node_Id;
+      Decls : List_Id;
 
-      function First_Declaration_Of_Current_Unit return Node_Id;
-      --  Return the current unit's first declaration. If the declaration list
-      --  is empty, the routine generates a null statement and returns it.
-
-      ---------------------------------------
-      -- First_Declaration_Of_Current_Unit --
-      ---------------------------------------
+   begin
+      if Nkind (Sem_U) = N_Package_Declaration then
+         Sem_U := Specification (Sem_U);
+         Decls := Visible_Declarations (Sem_U);
 
-      function First_Declaration_Of_Current_Unit return Node_Id is
-         Sem_U : Node_Id := Unit (Cunit (Current_Sem_Unit));
-         Decl  : Node_Id;
-         Decls : List_Id;
+         if No (Decls) then
+            Decl := Make_Null_Statement (Sloc (Sem_U));
+            Decls := New_List (Decl);
+            Set_Visible_Declarations (Sem_U, Decls);
 
-      begin
-         if Nkind (Sem_U) = N_Package_Declaration then
-            Sem_U := Specification (Sem_U);
-            Decls := Visible_Declarations (Sem_U);
-
-            if No (Decls) then
-               Decl  := Make_Null_Statement (Sloc (Sem_U));
-               Decls := New_List (Decl);
-               Set_Visible_Declarations (Sem_U, Decls);
-            else
-               Decl := First (Decls);
-            end if;
+         elsif Is_Empty_List (Decls) then
+            Decl := Make_Null_Statement (Sloc (Sem_U));
+            Append_To (Decls, Decl);
 
          else
-            Decls := Declarations (Sem_U);
-
-            if No (Decls) then
-               Decl  := Make_Null_Statement (Sloc (Sem_U));
-               Decls := New_List (Decl);
-               Set_Declarations (Sem_U, Decls);
-            else
-               Decl := First (Decls);
-            end if;
+            Decl := First (Decls);
          end if;
 
-         return Decl;
-      end First_Declaration_Of_Current_Unit;
-
-   --  Start of processing for Complete_Controlled_Allocation
-
-   begin
-      --  Certain run-time configurations and targets do not provide support
-      --  for controlled types.
-
-      if Restriction_Active (No_Finalization) then
-         return;
-
-      --  Do nothing if the access type may never allocate an object
+      else
+         Decls := Declarations (Sem_U);
 
-      elsif No_Pool_Assigned (Ptr_Typ) then
-         return;
+         if No (Decls) then
+            Decl := Make_Null_Statement (Sloc (Sem_U));
+            Decls := New_List (Decl);
+            Set_Declarations (Sem_U, Decls);
 
-      --  Access-to-controlled types are not supported on .NET/JVM
+         elsif Is_Empty_List (Decls) then
+            Decl := Make_Null_Statement (Sloc (Sem_U));
+            Append_To (Decls, Decl);
 
-      elsif VM_Target /= No_VM then
-         return;
+         else
+            Decl := First (Decls);
+         end if;
       end if;
 
-      --  ??? Now that finalization masters act as heterogeneous lists, it
-      --  might be worthed to revisit the global master approach.
-
-      --  Processing for anonymous access-to-controlled types. These access
-      --  types receive a special finalization master which appears in the
-      --  declarations of the enclosing semantic unit.
+      return Decl;
+   end Current_Unit_First_Declaration;
 
-      if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
-        and then No (Finalization_Master (Ptr_Typ))
-        and then
-          (not Restriction_Active (No_Nested_Finalization)
-             or else Is_Library_Level_Entity (Ptr_Typ))
-      then
-         declare
-            Pool_Id : constant Entity_Id :=
-                        Get_Global_Pool_For_Access_Type (Ptr_Typ);
-            Scop    : Node_Id := Cunit_Entity (Current_Sem_Unit);
+   ------------------------
+   -- Current_Unit_Scope --
+   ------------------------
 
-         begin
-            --  Use the scope of the current semantic unit when analyzing
+   function Current_Unit_Scope return Entity_Id is
+      Scop_Id  : Entity_Id := Cunit_Entity (Current_Sem_Unit);
+      Subp_Bod : Node_Id;
 
-            if Ekind (Scop) = E_Subprogram_Body then
-               Scop := Corresponding_Spec (Parent (Parent (Parent (Scop))));
-            end if;
+   begin
+      if Ekind (Scop_Id) = E_Subprogram_Body then
 
-            Build_Finalization_Master
-              (Typ        => Ptr_Typ,
-               Ins_Node   => First_Declaration_Of_Current_Unit,
-               Encl_Scope => Scop);
+         --  When processing subprogram bodies, the proper scope is always
+         --  that of the spec.
 
-            --  Decorate the anonymous access type and the allocator node
+         Subp_Bod := Scop_Id;
+         while Present (Subp_Bod)
+           and then Nkind (Subp_Bod) /= N_Subprogram_Body
+         loop
+            Subp_Bod := Parent (Subp_Bod);
+         end loop;
 
-            Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
-            Set_Storage_Pool (Expression (Temp_Decl), Pool_Id);
-         end;
+         Scop_Id := Corresponding_Spec (Subp_Bod);
       end if;
 
-      --  Since the temporary object reuses the original allocator, generate a
-      --  custom Allocate routine for the temporary.
-
-      if Present (Finalization_Master (Ptr_Typ)) then
-         Build_Allocate_Deallocate_Proc
-           (N           => Temp_Decl,
-            Is_Allocate => True);
-      end if;
-   end Complete_Controlled_Allocation;
+      return Scop_Id;
+   end Current_Unit_Scope;
 
    --------------------------------
    -- Displace_Allocator_Pointer --
@@ -777,14 +735,13 @@ package body Exp_Ch4 is
             return;
          end if;
 
-         --    Actions inserted before:
-         --              Temp : constant ptr_T := new T'(Expression);
-         --   <no CW>    Temp._tag := T'tag;
-         --   <CTRL>     Adjust (Finalizable (Temp.all));
-         --   <CTRL>     Attach_To_Final_List (Finalizable (Temp.all));
+         --  Actions inserted before:
+         --    Temp : constant ptr_T := new T'(Expression);
+         --    Temp._tag = T'tag;  --  when not class-wide
+         --    [Deep_]Adjust (Temp.all);
 
-         --  We analyze by hand the new internal allocator to avoid
-         --  any recursion and inappropriate call to Initialize
+         --  We analyze by hand the new internal allocator to avoid any
+         --  recursion and inappropriate call to Initialize
 
          --  We don't want to remove side effects when the expression must be
          --  built in place. In the case of a build-in-place function call,
@@ -858,7 +815,7 @@ package body Exp_Ch4 is
                Set_No_Initialization (Expression (Temp_Decl));
                Insert_Action (N, Temp_Decl);
 
-               Complete_Controlled_Allocation (Temp_Decl);
+               Build_Allocate_Deallocate_Proc (Temp_Decl, True);
                Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
 
                --  Attach the object to the associated finalization master.
@@ -889,7 +846,7 @@ package body Exp_Ch4 is
                    Expression          => Node);
 
                Insert_Action (N, Temp_Decl);
-               Complete_Controlled_Allocation (Temp_Decl);
+               Build_Allocate_Deallocate_Proc (Temp_Decl, True);
 
                --  Attach the object to the associated finalization master.
                --  This is done manually on .NET/JVM since those compilers do
@@ -961,7 +918,7 @@ package body Exp_Ch4 is
                   Set_No_Initialization (Expression (Temp_Decl));
                   Insert_Action (N, Temp_Decl);
 
-                  Complete_Controlled_Allocation (Temp_Decl);
+                  Build_Allocate_Deallocate_Proc (Temp_Decl, True);
                   Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
 
                else
@@ -976,7 +933,7 @@ package body Exp_Ch4 is
                       Expression          => Node);
 
                   Insert_Action (N, Temp_Decl);
-                  Complete_Controlled_Allocation (Temp_Decl);
+                  Build_Allocate_Deallocate_Proc (Temp_Decl, True);
                end if;
 
                --  Generate an additional object containing the address of the
@@ -1119,7 +1076,7 @@ package body Exp_Ch4 is
          Set_No_Initialization (Expression (Temp_Decl));
          Insert_Action (N, Temp_Decl);
 
-         Complete_Controlled_Allocation (Temp_Decl);
+         Build_Allocate_Deallocate_Proc (Temp_Decl, True);
          Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
 
          --  Attach the object to the associated finalization master. Thisis
@@ -3250,8 +3207,9 @@ package body Exp_Ch4 is
       Etyp  : constant Entity_Id  := Etype (Expression (N));
       Loc   : constant Source_Ptr := Sloc (N);
       Desig : Entity_Id;
-      Temp  : Entity_Id;
       Nod   : Node_Id;
+      Pool  : Entity_Id;
+      Temp  : Entity_Id;
 
       procedure Rewrite_Coextension (N : Node_Id);
       --  Static coextensions have the same lifetime as the entity they
@@ -3374,22 +3332,51 @@ package body Exp_Ch4 is
 
       Validate_Remote_Access_To_Class_Wide_Type (N);
 
-      --  Set the Storage Pool
+      --  Processing for anonymous access-to-controlled types. These access
+      --  types receive a special finalization master which appears in the
+      --  declarations of the enclosing semantic unit. This expansion is done
+      --  now to ensure that any additional types generated by this routine
+      --  or Expand_Allocator_Expression inherit the proper type attributes.
+
+      if Ekind (PtrT) = E_Anonymous_Access_Type
+        and then Needs_Finalization (Dtyp)
+      then
+         --  Anonymous access-to-controlled types allocate on the global pool
+
+         if No (Associated_Storage_Pool (PtrT)) then
+            Set_Associated_Storage_Pool (PtrT,
+              Get_Global_Pool_For_Access_Type (PtrT));
+         end if;
+
+         --  The finalization master must be inserted and analyzed as part of
+         --  the current semantic unit.
+
+         if No (Finalization_Master (PtrT)) then
+            Build_Finalization_Master
+              (Typ        => PtrT,
+               Ins_Node   => Current_Unit_First_Declaration,
+               Encl_Scope => Current_Unit_Scope);
+         end if;
+      end if;
+
+      --  Set the storage pool and find the appropriate version of Allocate to
+      --  call.
 
-      Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT)));
+      Pool := Associated_Storage_Pool (Root_Type (PtrT));
+      Set_Storage_Pool (N, Pool);
 
-      if Present (Storage_Pool (N)) then
-         if Is_RTE (Storage_Pool (N), RE_SS_Pool) then
+      if Present (Pool) then
+         if Is_RTE (Pool, RE_SS_Pool) then
             if VM_Target = No_VM then
                Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
             end if;
 
-         elsif Is_Class_Wide_Type (Etype (Storage_Pool (N))) then
+         elsif Is_Class_Wide_Type (Etype (Pool)) then
             Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
 
          else
             Set_Procedure_To_Call (N,
-              Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
+              Find_Prim_Op (Etype (Pool), Name_Allocate));
          end if;
       end if;
 
@@ -3550,7 +3537,7 @@ package body Exp_Ch4 is
               and then Present (Finalization_Master (PtrT))
             then
                Build_Allocate_Deallocate_Proc
-                 (N           => Parent (N),
+                 (N           => N,
                   Is_Allocate => True);
             end if;
 
@@ -3788,14 +3775,13 @@ package body Exp_Ch4 is
                Nod := Relocate_Node (N);
 
                --  Here is the transformation:
-               --    input:  new T
-               --    output: Temp : constant ptr_T := new T;
-               --            Init (Temp.all, ...);
-               --    <CTRL>  Attach_To_Final_List (Finalizable (Temp.all));
-               --    <CTRL>  Initialize (Finalizable (Temp.all));
+               --    input:  new Ctrl_Typ
+               --    output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
+               --            Ctrl_TypIP (Temp.all, ...);
+               --            [Deep_]Initialize (Temp.all);
 
-               --  Here ptr_T is the pointer type for the allocator, and is the
-               --  subtype of the allocator.
+               --  Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
+               --  is the subtype of the allocator.
 
                Temp_Decl :=
                  Make_Object_Declaration (Loc,
@@ -3807,7 +3793,7 @@ package body Exp_Ch4 is
                Set_Assignment_OK (Temp_Decl);
                Insert_Action (N, Temp_Decl, Suppress => All_Checks);
 
-               Complete_Controlled_Allocation (Temp_Decl);
+               Build_Allocate_Deallocate_Proc (Temp_Decl, True);
 
                --  If the designated type is a task type or contains tasks,
                --  create block to activate created tasks, and insert
@@ -3844,7 +3830,7 @@ package body Exp_Ch4 is
                   --  Special processing for .NET/JVM, the allocated object is
                   --  attached to the finalization master. Generate:
 
-                  --    Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
+                  --    Attach (<PtrT>FC, Root_Controlled_Ptr (Init_Arg1));
 
                   --  Types derived from [Limited_]Controlled are the only
                   --  ones considered since they have fields Prev and Next.
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 9ba5f6ecc56..c0c73feb715 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -777,9 +777,8 @@ package body Exp_Ch7 is
 
       return
         Make_Exception_Handler (Loc,
-          Exception_Choices => New_List (
-            Make_Others_Choice (Loc)),
-
+          Exception_Choices =>
+            New_List (Make_Others_Choice (Loc)),
           Statements => New_List (
             Make_If_Statement (Loc,
               Condition       =>
@@ -807,6 +806,7 @@ package body Exp_Ch7 is
       Encl_Scope : Entity_Id := Empty)
    is
       Desig_Typ : constant Entity_Id := Directly_Designated_Type (Typ);
+      Ptr_Typ   : Entity_Id := Root_Type (Base_Type (Typ));
 
       function In_Deallocation_Instance (E : Entity_Id) return Boolean;
       --  Determine whether entity E is inside a wrapper package created for
@@ -840,41 +840,57 @@ package body Exp_Ch7 is
    --  Start of processing for Build_Finalization_Master
 
    begin
+      if Is_Private_Type (Ptr_Typ)
+        and then Present (Full_View (Ptr_Typ))
+      then
+         Ptr_Typ := Full_View (Ptr_Typ);
+      end if;
+
       --  Certain run-time configurations and targets do not provide support
       --  for controlled types.
 
       if Restriction_Active (No_Finalization) then
          return;
 
+      --  Do not process C, C++, CIL and Java types since it is assumend that
+      --  the non-Ada side will handle their clean up.
+
+      elsif Convention (Desig_Typ) = Convention_C
+        or else Convention (Desig_Typ) = Convention_CIL
+        or else Convention (Desig_Typ) = Convention_CPP
+        or else Convention (Desig_Typ) = Convention_Java
+      then
+         return;
+
       --  Various machinery such as freezing may have already created a
       --  finalization master.
 
-      elsif Present (Finalization_Master (Typ)) then
+      elsif Present (Finalization_Master (Ptr_Typ)) then
          return;
 
       --  Do not process types that return on the secondary stack
 
-      elsif Present (Associated_Storage_Pool (Typ))
-        and then Is_RTE (Associated_Storage_Pool (Typ), RE_SS_Pool)
+      elsif Present (Associated_Storage_Pool (Ptr_Typ))
+        and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
       then
          return;
 
       --  Do not process types which may never allocate an object
 
-      elsif No_Pool_Assigned (Typ) then
+      elsif No_Pool_Assigned (Ptr_Typ) then
          return;
 
       --  Do not process access types coming from Ada.Unchecked_Deallocation
       --  instances. Even though the designated type may be controlled, the
       --  access type will never participate in allocation.
 
-      elsif In_Deallocation_Instance (Typ) then
+      elsif In_Deallocation_Instance (Ptr_Typ) then
          return;
 
       --  Ignore the general use of anonymous access types unless the context
       --  requires a finalization master.
 
-      elsif Ekind (Typ) = E_Anonymous_Access_Type
+      elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type
         and then No (Ins_Node)
       then
          return;
@@ -883,7 +899,7 @@ package body Exp_Ch7 is
       --  Finalization is in effect since masters are controlled objects.
 
       elsif Restriction_Active (No_Nested_Finalization)
-        and then not Is_Library_Level_Entity (Typ)
+        and then not Is_Library_Level_Entity (Ptr_Typ)
       then
          return;
 
@@ -898,19 +914,12 @@ package body Exp_Ch7 is
       end if;
 
       declare
-         Loc        : constant Source_Ptr := Sloc (Typ);
+         Loc        : constant Source_Ptr := Sloc (Ptr_Typ);
          Actions    : constant List_Id := New_List;
          Fin_Mas_Id : Entity_Id;
          Pool_Id    : Entity_Id;
-         Ptr_Typ    : Entity_Id := Typ;
 
       begin
-         --  Access subtypes must use the storage pool of their base type
-
-         if Ekind (Ptr_Typ) = E_Access_Subtype then
-            Ptr_Typ := Base_Type (Ptr_Typ);
-         end if;
-
          --  Generate:
          --    Fnn : aliased Finalization_Master;
 
@@ -994,11 +1003,10 @@ package body Exp_Ch7 is
 
             Pop_Scope;
 
-         elsif Ekind (Typ) = E_Access_Subtype
-           or else (Ekind (Desig_Typ) = E_Incomplete_Type
-                     and then Has_Completion_In_Body (Desig_Typ))
+         elsif Ekind (Desig_Typ) = E_Incomplete_Type
+           and then Has_Completion_In_Body (Desig_Typ)
          then
-            Insert_Actions (Parent (Typ), Actions);
+            Insert_Actions (Parent (Ptr_Typ), Actions);
 
          --  If the designated type is not yet frozen, then append the actions
          --  to that type's freeze actions. The actions need to be appended to
@@ -1013,10 +1021,10 @@ package body Exp_Ch7 is
          then
             Append_Freeze_Actions (Desig_Typ, Actions);
 
-         elsif Present (Freeze_Node (Typ))
-           and then not Analyzed (Freeze_Node (Typ))
+         elsif Present (Freeze_Node (Ptr_Typ))
+           and then not Analyzed (Freeze_Node (Ptr_Typ))
          then
-            Append_Freeze_Actions (Typ, Actions);
+            Append_Freeze_Actions (Ptr_Typ, Actions);
 
          --  If there's a pool created locally for the access type, then we
          --  need to ensure that the master gets created after the pool object,
@@ -1027,12 +1035,12 @@ package body Exp_Ch7 is
          --  this point. (This seems a little unclean.???)
 
          elsif VM_Target = No_VM
-           and then Scope (Pool_Id) = Scope (Typ)
+           and then Scope (Pool_Id) = Scope (Ptr_Typ)
          then
             Insert_List_After_And_Analyze (Parent (Pool_Id), Actions);
 
          else
-            Insert_Actions (Parent (Typ), Actions);
+            Insert_Actions (Parent (Ptr_Typ), Actions);
          end if;
       end;
    end Build_Finalization_Master;
@@ -1448,8 +1456,8 @@ package body Exp_Ch7 is
             --  The local exception does not need to be reraised for library-
             --  level finalizers. Generate:
             --
-            --    if Raised then
-            --       Raise_From_Controlled_Operation (E, Abort);
+            --    if Raised and then not Abort then
+            --       Raise_From_Controlled_Operation (E);
             --    end if;
 
             if not For_Package
@@ -2297,6 +2305,10 @@ package body Exp_Ch7 is
 
                      if Is_Controlled (Typ) then
                         Init := Find_Prim_Op (Typ, Name_Initialize);
+
+                        if Present (Init) then
+                           Init := Ultimate_Alias (Init);
+                        end if;
                      end if;
 
                      return
@@ -2349,6 +2361,12 @@ package body Exp_Ch7 is
                Utyp := Typ;
             end if;
 
+            if Is_Private_Type (Utyp)
+              and then Present (Full_View (Utyp))
+            then
+               Utyp := Full_View (Utyp);
+            end if;
+
             --  The init procedures are arranged as follows:
 
             --    Object : Controlled_Type;
@@ -3086,20 +3104,13 @@ package body Exp_Ch7 is
       E_Id      : Entity_Id;
       Raised_Id : Entity_Id) return Node_Id
    is
-      Params  : List_Id;
       Proc_Id : Entity_Id;
 
    begin
-      --  The default parameter is the local exception occurrence
-
-      Params := New_List (New_Reference_To (E_Id, Loc));
-
-      --  Standard run-time, .NET/JVM targets, this case handles finalization
-      --  exceptions raised during an abort.
+      --  Standard run-time, .NET/JVM targets
 
       if RTE_Available (RE_Raise_From_Controlled_Operation) then
          Proc_Id := RTE (RE_Raise_From_Controlled_Operation);
-         Append_To (Params, New_Reference_To (Abort_Id, Loc));
 
       --  Restricted runtime: exception messages are not supported and hence
       --  Raise_From_Controlled_Operation is not supported.
@@ -3109,17 +3120,24 @@ package body Exp_Ch7 is
       end if;
 
       --  Generate:
-      --    if Raised_Id then
+      --    if Raised_Id and then not Abort_Id then
       --       <Proc_Id> (<Params>);
       --    end if;
 
       return
         Make_If_Statement (Loc,
-          Condition       => New_Reference_To (Raised_Id, Loc),
+          Condition =>
+            Make_And_Then (Loc,
+              Left_Opnd  => New_Reference_To (Raised_Id, Loc),
+              Right_Opnd =>
+                Make_Op_Not (Loc,
+                  Right_Opnd => New_Reference_To (Abort_Id, Loc))),
+
           Then_Statements => New_List (
             Make_Procedure_Call_Statement (Loc,
               Name                   => New_Reference_To (Proc_Id, Loc),
-              Parameter_Associations => Params)));
+              Parameter_Associations =>
+                New_List (New_Reference_To (E_Id, Loc)))));
    end Build_Raise_Statement;
 
    -----------------------------
@@ -4325,8 +4343,8 @@ package body Exp_Ch7 is
 
                --    exception
                --       when others =>
-               --          if not Rnn then
-               --             Rnn := True;
+               --          if not Raised then
+               --             Raised := True;
                --             Save_Occurrence
                --               (Enn, Get_Current_Excep.all.all);
                --          end if;
@@ -4405,8 +4423,8 @@ package body Exp_Ch7 is
          end loop;
 
          --  Generate:
-         --    if Rnn then
-         --       Raise_From_Controlled_Operation (E, Abort);
+         --    if Raised and then not Abort then
+         --       Raise_From_Controlled_Operation (E);
          --    end if;
 
          if Built
@@ -4723,8 +4741,8 @@ package body Exp_Ch7 is
       --          ...
       --       end loop;
       --
-      --       if Raised then
-      --          Raise_From_Controlled_Operation (E, Abort);
+      --       if Raised and then not Abort then
+      --          Raise_From_Controlled_Operation (E);
       --       end if;
       --    end;
 
@@ -4789,8 +4807,8 @@ package body Exp_Ch7 is
       --                      end loop;
       --                   end;
 
-      --                   if Raised then
-      --                      Raise_From_Controlled_Operation (E, Abort);
+      --                   if Raised and then not Abort then
+      --                      Raise_From_Controlled_Operation (E);
       --                   end if;
 
       --                   raise;
@@ -4957,8 +4975,8 @@ package body Exp_Ch7 is
          --    begin
          --       <core loop>
 
-         --       if Raised then  --  Expection handlers allowed
-         --          Raise_From_Controlled_Operation (E, Abort);
+         --       if Raised and then not Abort then  --  Expection handlers OK
+         --          Raise_From_Controlled_Operation (E);
          --       end if;
          --    end;
 
@@ -5249,11 +5267,11 @@ package body Exp_Ch7 is
 
          --       <final loop>
 
-         --       if Raised then  --  Exception handlers allowed
-         --          Raise_From_Controlled_Operation (E, Abort);
+         --       if Raised and then not Abort then  --  Exception handlers OK
+         --          Raise_From_Controlled_Operation (E);
          --       end if;
 
-         --       raise;          --  Exception handlers allowed
+         --       raise;  --  Exception handlers OK
          --    end;
 
          Stmts := New_List (Build_Counter_Assignment, Final_Loop);
@@ -5537,8 +5555,8 @@ package body Exp_Ch7 is
       --          end;
       --       end if;
       --
-      --       if Raised then
-      --          Raise_From_Controlled_Object (E, Abort);
+      --       if Raised and then not Abort then
+      --          Raise_From_Controlled_Operation (E);
       --       end if;
       --    end;
 
@@ -5622,8 +5640,8 @@ package body Exp_Ch7 is
       --             end if;
       --       end;
       --
-      --       if Raised then
-      --          Raise_From_Controlled_Object (E, Abort);
+      --       if Raised and then not Abort then
+      --          Raise_From_Controlled_Operation (E);
       --       end if;
       --    end;
 
@@ -6036,8 +6054,8 @@ package body Exp_Ch7 is
          --    begin
          --       <adjust statements>
 
-         --       if Raised then
-         --          Raise_From_Controlled_Operation (E, Abort);
+         --       if Raised and then not Abort then
+         --          Raise_From_Controlled_Operation (E);
          --       end if;
          --    end;
 
@@ -6618,15 +6636,10 @@ package body Exp_Ch7 is
          --       Raised : Boolean := False;
 
          --    begin
-         --       if V.Finalized then
-         --          return;
-         --       end if;
-
          --       <finalize statements>
-         --       V.Finalized := True;
 
-         --       if Raised then
-         --          Raise_From_Controlled_Operation (E, Abort);
+         --       if Raised and then not Abort then
+         --          Raise_From_Controlled_Operation (E);
          --       end if;
          --    end;
 
@@ -6917,16 +6930,29 @@ package body Exp_Ch7 is
    --------------------------------
 
    procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
+      Is_Task : constant Boolean :=
+                  Ekind (Typ) = E_Record_Type
+                    and then Is_Concurrent_Record_Type (Typ)
+                    and then Ekind (Corresponding_Concurrent_Type (Typ)) =
+                               E_Task_Type;
       Loc     : constant Source_Ptr := Sloc (Typ);
       Proc_Id : Entity_Id;
+      Stmts   : List_Id;
 
    begin
+      --  The corresponding records of task types are not controlled by design.
+      --  For the sake of completeness, create an empty Finalize_Address to be
+      --  used in task class-wide allocations.
+
+      if Is_Task then
+         null;
+
       --  Nothing to do if the type is not controlled or it already has a
       --  TSS entry for Finalize_Address. Skip class-wide subtypes which do not
       --  come from source. These are usually generated for completeness and
       --  do not need the Finalize_Address primitive.
 
-      if not Needs_Finalization (Typ)
+      elsif not Needs_Finalization (Typ)
         or else Is_Abstract_Type (Typ)
         or else Present (TSS (Typ, TSS_Finalize_Address))
         or else
@@ -6944,7 +6970,9 @@ package body Exp_Ch7 is
       --  Generate:
       --    procedure <Typ>FD (V : System.Address) is
       --    begin
-      --       declare
+      --       null;                            --  for tasks
+      --
+      --       declare                          --  for all other types
       --          type Pnn is access all Typ;
       --          for Pnn'Storage_Size use 0;
       --       begin
@@ -6952,6 +6980,12 @@ package body Exp_Ch7 is
       --       end;
       --    end TypFD;
 
+      if Is_Task then
+         Stmts := New_List (Make_Null_Statement (Loc));
+      else
+         Stmts := Make_Finalize_Address_Stmts (Typ);
+      end if;
+
       Discard_Node (
         Make_Subprogram_Body (Loc,
           Specification =>
@@ -6969,8 +7003,7 @@ package body Exp_Ch7 is
 
           Handled_Statement_Sequence =>
             Make_Handled_Sequence_Of_Statements (Loc,
-              Statements =>
-                Make_Finalize_Address_Stmts (Typ))));
+              Statements => Stmts)));
 
       Set_TSS (Typ, Proc_Id);
    end Make_Finalize_Address_Body;
@@ -7218,7 +7251,7 @@ package body Exp_Ch7 is
    --  Generate:
 
    --    when E : others =>
-   --      Raise_From_Controlled_Operation (E, False);
+   --      Raise_From_Controlled_Operation (E);
 
    --  or:
 
@@ -7250,8 +7283,7 @@ package body Exp_Ch7 is
                New_Reference_To
                  (RTE (RE_Raise_From_Controlled_Operation), Loc),
              Parameter_Associations => New_List (
-               New_Reference_To (E_Occ, Loc),
-               New_Reference_To (Standard_False, Loc)));
+               New_Reference_To (E_Occ, Loc)));
 
       --  Restricted runtime: exception messages are not supported
 
diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads
index 25b339559f9..a9fea526c22 100644
--- a/gcc/ada/exp_ch7.ads
+++ b/gcc/ada/exp_ch7.ads
@@ -84,8 +84,8 @@ package Exp_Ch7 is
    --  Subsidiary to routines Build_Finalizer, Make_Deep_Array_Body and Make_
    --  Deep_Record_Body. Generate the following conditional raise statement:
    --
-   --    if Raised_Id then
-   --       Raise_From_Controlled_Operation (E_Id, Abort_Id);
+   --    if Raised_Id and then not Abort_Id then
+   --       Raise_From_Controlled_Operation (E_Id);
    --    end if;
    --
    --  Abort_Id is a local boolean flag which is set when the finalization was
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index e06b9e075a4..0d1f73c4044 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -327,10 +327,11 @@ package body Exp_Util is
      (N           : Node_Id;
       Is_Allocate : Boolean)
    is
-      Expr      : constant Node_Id   := Expression (N);
-      Ptr_Typ   : constant Entity_Id := Etype (Expr);
-      Desig_Typ : constant Entity_Id :=
-                    Available_View (Designated_Type (Ptr_Typ));
+      Desig_Typ    : Entity_Id;
+      Expr         : Node_Id;
+      Pool_Id      : Entity_Id;
+      Proc_To_Call : Node_Id := Empty;
+      Ptr_Typ      : Entity_Id;
 
       function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id;
       --  Locate TSS primitive Finalize_Address in type Typ
@@ -351,13 +352,33 @@ package body Exp_Util is
          Utyp : Entity_Id := Typ;
 
       begin
+         --  Handle protected class-wide or task class-wide types
+
+         if Is_Class_Wide_Type (Utyp) then
+            if Is_Concurrent_Type (Root_Type (Utyp)) then
+               Utyp := Root_Type (Utyp);
+
+            elsif Is_Private_Type (Root_Type (Utyp))
+              and then Present (Full_View (Root_Type (Utyp)))
+              and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
+            then
+               Utyp := Full_View (Root_Type (Utyp));
+            end if;
+         end if;
+
+         --  Handle private types
+
          if Is_Private_Type (Utyp)
            and then Present (Full_View (Utyp))
          then
             Utyp := Full_View (Utyp);
          end if;
 
-         if Is_Concurrent_Type (Utyp) then
+         --  Handle protected and task types
+
+         if Is_Concurrent_Type (Utyp)
+           and then Present (Corresponding_Record_Type (Utyp))
+         then
             Utyp := Corresponding_Record_Type (Utyp);
          end if;
 
@@ -459,18 +480,91 @@ package body Exp_Util is
    --  Start of processing for Build_Allocate_Deallocate_Proc
 
    begin
-      --  The allocation / deallocation of a non-controlled object does not
-      --  need the machinery created by this routine.
+      --  Obtain the attributes of the allocation / deallocation
+
+      if Nkind (N) = N_Free_Statement then
+         Expr := Expression (N);
+         Ptr_Typ := Base_Type (Etype (Expr));
+         Proc_To_Call := Procedure_To_Call (N);
+
+      else
+         if Nkind (N) = N_Object_Declaration then
+            Expr := Expression (N);
+         else
+            Expr := N;
+         end if;
+
+         Ptr_Typ := Base_Type (Etype (Expr));
+
+         --  The allocator may have been rewritten into something else
+
+         if Nkind (Expr) = N_Allocator then
+            Proc_To_Call := Procedure_To_Call (Expr);
+         end if;
+      end if;
+
+      Pool_Id := Associated_Storage_Pool (Ptr_Typ);
+      Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
 
-      if not Needs_Finalization (Desig_Typ) then
+      --  Handle concurrent types
+
+      if Is_Concurrent_Type (Desig_Typ)
+        and then Present (Corresponding_Record_Type (Desig_Typ))
+      then
+         Desig_Typ := Corresponding_Record_Type (Desig_Typ);
+      end if;
+
+      --  Do not process allocations / deallocations without a pool
+
+      if No (Pool_Id) then
          return;
 
-      --  The allocator or free statement has already been expanded and already
-      --  has a custom Allocate / Deallocate routine.
+      --  Do not process allocations on / deallocations from the secondary
+      --  stack.
+
+      elsif Is_RTE (Pool_Id, RE_SS_Pool) then
+         return;
+
+      --  Do not replicate the machinery if the allocator / free has already
+      --  been expanded and has a custom Allocate / Deallocate.
+
+      elsif Present (Proc_To_Call)
+        and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
+      then
+         return;
+      end if;
+
+      if Needs_Finalization (Desig_Typ) then
+
+         --  Certain run-time configurations and targets do not provide support
+         --  for controlled types.
+
+         if Restriction_Active (No_Finalization) then
+            return;
+
+         --  Do nothing if the access type may never allocate / deallocate
+         --  objects.
+
+         elsif No_Pool_Assigned (Ptr_Typ) then
+            return;
+
+         --  Access-to-controlled types are not supported on .NET/JVM since
+         --  these targets cannot support pools and address arithmetic.
+
+         elsif VM_Target /= No_VM then
+            return;
+         end if;
+
+         --  The allocation / deallocation of a controlled object must be
+         --  chained on / detached from a finalization master.
+
+         pragma Assert (Present (Finalization_Master (Ptr_Typ)));
+
+      --  The only other kind of allocation / deallocation supported by this
+      --  routine is on / from a subpool.
 
       elsif Nkind (Expr) = N_Allocator
-        and then Present (Procedure_To_Call (Expr))
-        and then Is_Allocate_Deallocate_Proc (Procedure_To_Call (Expr))
+        and then No (Subpool_Handle_Name (Expr))
       then
          return;
       end if;
@@ -486,36 +580,27 @@ package body Exp_Util is
          Fin_Addr_Id  : Entity_Id;
          Fin_Mas_Act  : Node_Id;
          Fin_Mas_Id   : Entity_Id;
-         Fin_Mas_Typ  : Entity_Id;
          Proc_To_Call : Entity_Id;
+         Subpool      : Node_Id := Empty;
 
       begin
-         --  When dealing with an access subtype, always use the base type
-         --  since it carries all the attributes.
-
-         if Ekind (Ptr_Typ) = E_Access_Subtype then
-            Fin_Mas_Typ := Base_Type (Ptr_Typ);
-         else
-            Fin_Mas_Typ := Ptr_Typ;
-         end if;
-
-         Actuals := New_List;
-
          --  Step 1: Construct all the actuals for the call to library routine
          --  Allocate_Any_Controlled / Deallocate_Any_Controlled.
 
          --  a) Storage pool
 
-         Append_To (Actuals,
-           New_Reference_To (Associated_Storage_Pool (Fin_Mas_Typ), Loc));
+         Actuals := New_List (New_Reference_To (Pool_Id, Loc));
 
          if Is_Allocate then
 
             --  b) Subpool
 
-            if Present (Subpool_Handle_Name (Expr)) then
-               Append_To (Actuals,
-                 New_Reference_To (Entity (Subpool_Handle_Name (Expr)), Loc));
+            if Nkind (Expr) = N_Allocator then
+               Subpool := Subpool_Handle_Name (Expr);
+            end if;
+
+            if Present (Subpool) then
+               Append_To (Actuals, New_Reference_To (Entity (Subpool), Loc));
             else
                Append_To (Actuals, Make_Null (Loc));
             end if;
@@ -523,7 +608,7 @@ package body Exp_Util is
             --  c) Finalization master
 
             if Needs_Finalization (Desig_Typ) then
-               Fin_Mas_Id  := Finalization_Master (Fin_Mas_Typ);
+               Fin_Mas_Id  := Finalization_Master (Ptr_Typ);
                Fin_Mas_Act := New_Reference_To (Fin_Mas_Id, Loc);
 
                --  Handle the case where the master is actually a pointer to a
@@ -545,7 +630,9 @@ package body Exp_Util is
 
             Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
 
-            if Present (Fin_Addr_Id) then
+            if Needs_Finalization (Desig_Typ) then
+               pragma Assert (Present (Fin_Addr_Id));
+
                Append_To (Actuals,
                  Make_Attribute_Reference (Loc,
                    Prefix         => New_Reference_To (Fin_Addr_Id, Loc),
@@ -654,11 +741,23 @@ package body Exp_Util is
 
                   Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
                end;
+
+            --  The object is statically known to be controlled
+
+            else
+               Append_To (Actuals, New_Reference_To (Standard_True, Loc));
             end if;
          else
             Append_To (Actuals, New_Reference_To (Standard_False, Loc));
          end if;
 
+         --  i) On_Subpool
+
+         if Is_Allocate then
+            Append_To (Actuals,
+              New_Reference_To (Boolean_Literals (Present (Subpool)), Loc));
+         end if;
+
          --  Step 2: Build a wrapper Allocate / Deallocate which internally
          --  calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
 
@@ -5296,6 +5395,16 @@ package body Exp_Util is
       if Restriction_Active (No_Finalization) then
          return False;
 
+      --  C, C++, CIL and Java types are not considered controlled. It is
+      --  assumed that the non-Ada side will handle their clean up.
+
+      elsif Convention (T) = Convention_C
+        or else Convention (T) = Convention_CIL
+        or else Convention (T) = Convention_CPP
+        or else Convention (T) = Convention_Java
+      then
+         return False;
+
       else
          --  Class-wide types are treated as controlled because derivations
          --  from the root type can introduce controlled components.
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 7058ceb887d..1f0ee42fc5d 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -198,8 +198,13 @@ package Exp_Util is
      (N           : Node_Id;
       Is_Allocate : Boolean);
    --  Create a custom Allocate/Deallocate to be associated with an allocation
-   --  or deallocation of a controlled or class-wide object. In the case of
-   --  allocation, N is the declaration of the temporary variable which
+   --  or deallocation:
+   --
+   --    1) controlled objects
+   --    2) class-wide objects
+   --    3) any kind of object on a subpool
+   --
+   --  N must be an allocator or the declaration of a temporary variable which
    --  represents the expression of the original allocator node, otherwise N
    --  must be a free statement. If flag Is_Allocate is set, the generated
    --  routine is allocate, deallocate otherwise.
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 0d3c1312538..3917aa40aa1 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -1439,27 +1439,24 @@ package body Freeze is
                end loop;
             end;
 
-         --  We add finalization collections to access types whose designated
-         --  types require finalization. This is normally done when freezing
-         --  the type, but this misses recursive type definitions where the
-         --  later members of the recursion introduce controlled components
-         --  (such as can happen when incomplete types are involved), as well
-         --  cases where a component type is private and the controlled full
-         --  type occurs after the access type is frozen. Cases that don't
-         --  need a finalization collection are generic formal types (the
-         --  actual type will have it) and types with Java and CIL conventions,
-         --  since those are used for API bindings. (Are there any other cases
-         --  that should be excluded here???)
+         --  We add finalization masters to access types whose designated types
+         --  require finalization. This is normally done when freezing the
+         --  type, but this misses recursive type definitions where the later
+         --  members of the recursion introduce controlled components (such as
+         --  can happen when incomplete types are involved), as well cases
+         --  where a component type is private and the controlled full type
+         --  occurs after the access type is frozen. Cases that don't need a
+         --  finalization master are generic formal types (the actual type will
+         --  have it) and types with Java and CIL conventions, since those are
+         --  used for API bindings. (Are there any other cases that should be
+         --  excluded here???)
 
          elsif Is_Access_Type (E)
            and then Comes_From_Source (E)
            and then not Is_Generic_Type (E)
            and then Needs_Finalization (Designated_Type (E))
-           and then No (Associated_Collection (E))
-           and then Convention (Designated_Type (E)) /= Convention_Java
-           and then Convention (Designated_Type (E)) /= Convention_CIL
          then
-            Build_Finalization_Collection (E);
+            Build_Finalization_Master (E);
          end if;
 
          Next_Entity (E);
diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb
index de05fdfd6eb..ea636fe8b0a 100644
--- a/gcc/ada/impunit.adb
+++ b/gcc/ada/impunit.adb
@@ -346,6 +346,7 @@ package body Impunit is
 
      "s-addima",    -- System.Address_Image
      "s-assert",    -- System.Assertions
+     "s-finmas",    -- System.Finalization_Masters
      "s-memory",    -- System.Memory
      "s-parint",    -- System.Partition_Interface
      "s-pooglo",    -- System.Pool_Global
@@ -508,6 +509,7 @@ package body Impunit is
    Non_Imp_File_Names_12 : constant File_List := (
      "s-multip",    -- System.Multiprocessors
      "s-mudido",    -- System.Multiprocessors.Dispatching_Domains
+     "s-stposu",    -- System.Storage_Pools.Subpools
      "a-cobove",    -- Ada.Containers.Bounded_Vectors
      "a-cbdlli",    -- Ada.Containers.Bounded_Doubly_Linked_Lists
      "a-cborse",    -- Ada.Containers.Bounded_Ordered_Sets
@@ -521,11 +523,13 @@ package body Impunit is
      "a-extiin",    -- Ada.Execution_Time.Interrupts
      "a-iteint",    -- Ada.Iterator_Interfaces
      "a-synbar",    -- Ada.Synchronous_Barriers
+     "a-undesu",    -- Ada.Unchecked_Deallocate_Subpool
 
    -----------------------------------------
    -- GNAT Defined Additions to Ada 20012 --
    -----------------------------------------
 
+     "s-spsufi",    -- System.Storage_Pools.Subpools.Finalization
      "a-cofove",    -- Ada.Containers.Formal_Vectors
      "a-cfdlli",    -- Ada.Containers.Formal_Doubly_Linked_Lists
      "a-cforse",    -- Ada.Containers.Formal_Ordered_Sets
diff --git a/gcc/ada/s-finmas.ads b/gcc/ada/s-finmas.ads
index 26783d33172..cd2b74c987c 100644
--- a/gcc/ada/s-finmas.ads
+++ b/gcc/ada/s-finmas.ads
@@ -35,6 +35,8 @@ with Ada.Unchecked_Conversion;
 with System.Storage_Elements;
 with System.Storage_Pools;
 
+pragma Compiler_Unit;
+
 package System.Finalization_Masters is
    pragma Preelaborate (System.Finalization_Masters);
 
diff --git a/gcc/ada/s-spsufi.adb b/gcc/ada/s-spsufi.adb
new file mode 100644
index 00000000000..86b18aad7df
--- /dev/null
+++ b/gcc/ada/s-spsufi.adb
@@ -0,0 +1,62 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--        S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S .       --
+--                          F I N A L I Z A T I O N                         --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--             Copyright (C) 2011, 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 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.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+package body System.Storage_Pools.Subpools.Finalization is
+
+   -----------------------------
+   -- Finalize_And_Deallocate --
+   -----------------------------
+
+   procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle) is
+   begin
+      --  Do nothing if the subpool was never created or never used. The latter
+      --  case may arise with an array of subpool implementations.
+
+      if Subpool = null
+        or else Subpool.Owner = null
+        or else Subpool.Node = null
+      then
+         return;
+      end if;
+
+      --  Clean up all controlled objects allocated through the subpool
+
+      Finalize_Subpool (Subpool);
+
+      --  Dispatch to the user-defined implementation of Deallocate_Subpool
+
+      Deallocate_Subpool (Pool_Of_Subpool (Subpool).all, Subpool);
+
+      Subpool := null;
+   end Finalize_And_Deallocate;
+
+end System.Storage_Pools.Subpools.Finalization;
diff --git a/gcc/ada/s-spsufi.ads b/gcc/ada/s-spsufi.ads
new file mode 100644
index 00000000000..66aac4b07a9
--- /dev/null
+++ b/gcc/ada/s-spsufi.ads
@@ -0,0 +1,44 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--        S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S .       --
+--                          F I N A L I Z A T I O N                         --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--             Copyright (C) 2011, 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 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.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Compiler_Unit;
+
+package System.Storage_Pools.Subpools.Finalization is
+
+   procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle);
+   --  This routine performs the following actions:
+   --    1) Finalize all objects chained on the subpool's master
+   --    2) Remove the the subpool from the owner's list of subpools
+   --    3) Deallocate the doubly linked list node associated with the subpool
+   --    4) Call Deallocate_Subpool
+
+end System.Storage_Pools.Subpools.Finalization;
diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb
index 0e67bba3402..e7436c6088f 100644
--- a/gcc/ada/s-stposu.adb
+++ b/gcc/ada/s-stposu.adb
@@ -61,10 +61,6 @@ package body System.Storage_Pools.Subpools is
       Alignment                : System.Storage_Elements.Storage_Count)
    is
    begin
-      --  ??? The use of Allocate is very dangerous as it does not handle
-      --  controlled objects properly. Perhaps we should provide an
-      --  implementation which raises Program_Error instead.
-
       --  Dispatch to the user-defined implementations of Allocate_From_Subpool
       --  and Default_Subpool_For_Pool.
 
@@ -83,13 +79,14 @@ package body System.Storage_Pools.Subpools is
 
    procedure Allocate_Any_Controlled
      (Pool            : in out Root_Storage_Pool'Class;
-      Context_Subpool : Subpool_Handle := null;
-      Context_Master  : Finalization_Masters.Finalization_Master_Ptr := null;
-      Fin_Address     : Finalization_Masters.Finalize_Address_Ptr := null;
+      Context_Subpool : Subpool_Handle;
+      Context_Master  : Finalization_Masters.Finalization_Master_Ptr;
+      Fin_Address     : Finalization_Masters.Finalize_Address_Ptr;
       Addr            : out System.Address;
       Storage_Size    : System.Storage_Elements.Storage_Count;
       Alignment       : System.Storage_Elements.Storage_Count;
-      Is_Controlled   : Boolean := True)
+      Is_Controlled   : Boolean;
+      On_Subpool      : Boolean)
    is
       Is_Subpool_Allocation : constant Boolean :=
                                 Pool in Root_Storage_Pool_With_Subpools'Class;
@@ -108,7 +105,7 @@ package body System.Storage_Pools.Subpools is
       --  Step 1: Pool-related runtime checks
 
       --  Allocation on a pool_with_subpools. In this scenario there is a
-      --  master for each subpool.
+      --  master for each subpool. The master of the access type is ignored.
 
       if Is_Subpool_Allocation then
 
@@ -120,26 +117,21 @@ package body System.Storage_Pools.Subpools is
               Default_Subpool_For_Pool
                 (Root_Storage_Pool_With_Subpools'Class (Pool));
 
-            --  Ensure proper ownership
-
-            if Subpool.Owner /=
-                 Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
-            then
-               raise Program_Error with "incorrect owner of default subpool";
-            end if;
-
          --  Allocation with a Subpool_Handle
 
          else
             Subpool := Context_Subpool;
+         end if;
 
-            --  Ensure proper ownership
+         --  Ensure proper ownership and chaining of the subpool
 
-            if Subpool.Owner /=
-                 Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
-            then
-               raise Program_Error with "incorrect owner of subpool";
-            end if;
+         if Subpool.Owner /=
+              Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
+           or else Subpool.Node = null
+           or else Subpool.Node.Prev = null
+           or else Subpool.Node.Next = null
+         then
+            raise Program_Error with "incorrect owner of subpool";
          end if;
 
          Master := Subpool.Master'Unchecked_Access;
@@ -148,25 +140,35 @@ package body System.Storage_Pools.Subpools is
       --  each access-to-controlled type. No context subpool should be present.
 
       else
-
          --  If the master is missing, then the expansion of the access type
          --  failed to create one. This is a serious error.
 
          if Context_Master = null then
             raise Program_Error with "missing master in pool allocation";
+         end if;
 
          --  If a subpool is present, then this is the result of erroneous
          --  allocator expansion. This is not a serious error, but it should
          --  still be detected.
 
-         elsif Context_Subpool /= null then
+         if Context_Subpool /= null then
             raise Program_Error with "subpool not required in pool allocation";
          end if;
 
+         --  If the allocation is intended to be on a subpool, but the access
+         --  type's pool does not support subpools, then this is the result of
+         --  erroneous end-user code.
+
+         if On_Subpool then
+            raise Program_Error
+              with "pool of access type does not support subpools";
+         end if;
+
          Master := Context_Master;
       end if;
 
-      --  Step 2: Master-related runtime checks and size calculations
+      --  Step 2: Master and Finalize_Address-related runtime checks and size
+      --  calculations.
 
       --  Allocation of a descendant from [Limited_]Controlled, a class-wide
       --  object or a record with controlled components.
@@ -180,6 +182,15 @@ package body System.Storage_Pools.Subpools is
             raise Program_Error with "allocation after finalization started";
          end if;
 
+         --  Check whether primitive Finalize_Address is available. If it is
+         --  not, then either the expansion of the designated type failed or
+         --  the expansion of the allocator failed. This is a serious error.
+
+         if Fin_Address = null then
+            raise Program_Error
+              with "primitive Finalize_Address not available";
+         end if;
+
          --  The size must acount for the hidden header preceding the object.
          --  Account for possible padding space before the header due to a
          --  larger alignment.
@@ -224,29 +235,20 @@ package body System.Storage_Pools.Subpools is
          --  due to larger alignment, the header is placed right next to the
          --  object:
 
-         --    N_Addr  N_Ptr
-         --    |       |
-         --    V       V
-         --    +-------+---------------+----------------------+
-         --    |Padding|    Header     |        Object        |
-         --    +-------+---------------+----------------------+
-         --    ^       ^               ^
-         --    |       +- Header_Size -+
-         --    |                       |
-         --    +- Header_And_Padding --+
+         --     N_Addr  N_Ptr
+         --     |       |
+         --     V       V
+         --     +-------+---------------+----------------------+
+         --     |Padding|    Header     |        Object        |
+         --     +-------+---------------+----------------------+
+         --     ^       ^               ^
+         --     |       +- Header_Size -+
+         --     |                       |
+         --     +- Header_And_Padding --+
 
          N_Ptr :=
            Address_To_FM_Node_Ptr (N_Addr + Header_And_Padding - Header_Size);
 
-         --  Check whether primitive Finalize_Address is available. If it is
-         --  not, then either the expansion of the designated type failed or
-         --  the expansion of the allocator failed. This is a serious error.
-
-         if Fin_Address = null then
-            raise Program_Error
-              with "primitive Finalize_Address not available";
-         end if;
-
          N_Ptr.Finalize_Address := Fin_Address;
 
          --  Prepend the allocated object to the finalization master
@@ -268,6 +270,10 @@ package body System.Storage_Pools.Subpools is
 
    procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr) is
    begin
+      --  Ensure that the node has not been attached already
+
+      pragma Assert (N.Prev = null and then N.Next = null);
+
       Lock_Task.all;
 
       L.Next.Prev := N;
@@ -290,7 +296,7 @@ package body System.Storage_Pools.Subpools is
       Addr          : System.Address;
       Storage_Size  : System.Storage_Elements.Storage_Count;
       Alignment     : System.Storage_Elements.Storage_Count;
-      Is_Controlled : Boolean := True)
+      Is_Controlled : Boolean)
    is
       N_Addr : Address;
       N_Ptr  : FM_Node_Ptr;
@@ -360,7 +366,7 @@ package body System.Storage_Pools.Subpools is
 
    procedure Detach (N : not null SP_Node_Ptr) is
    begin
-      --  N must be attached to some list
+      --  Ensure that the node is attached to some list
 
       pragma Assert (N.Next /= null and then N.Prev /= null);
 
@@ -379,22 +385,22 @@ package body System.Storage_Pools.Subpools is
    -- Finalize --
    --------------
 
-   overriding procedure Finalize
-     (Pool : in out Root_Storage_Pool_With_Subpools)
-   is
+   overriding procedure Finalize (Controller : in out Pool_Controller) is
+   begin
+      Finalize_Pool (Controller.Enclosing_Pool.all);
+   end Finalize;
+
+   -------------------
+   -- Finalize_Pool --
+   -------------------
+
+   procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
       Curr_Ptr : SP_Node_Ptr;
       Ex_Occur : Exception_Occurrence;
       Next_Ptr : SP_Node_Ptr;
       Raised   : Boolean := False;
 
    begin
-      --  Uninitialized pools do not have subpools and do not contain objects
-      --  of any kind.
-
-      if not Pool.Initialized then
-         return;
-      end if;
-
       --  It is possible for multiple tasks to cause the finalization of a
       --  common pool. Allow only one task to finalize the contents.
 
@@ -415,11 +421,12 @@ package body System.Storage_Pools.Subpools is
       while Curr_Ptr /= Pool.Subpools'Unchecked_Access loop
          Next_Ptr := Curr_Ptr.Next;
 
-         --  Remove the subpool node from the subpool list
+         --  Perform the following actions:
 
-         Detach (Curr_Ptr);
-
-         --  Finalize the current subpool
+         --    1) Finalize all objects chained on the subpool's master
+         --    2) Remove the the subpool from the owner's list of subpools
+         --    3) Deallocate the doubly linked list node associated with the
+         --       subpool.
 
          begin
             Finalize_Subpool (Curr_Ptr.Subpool);
@@ -432,11 +439,6 @@ package body System.Storage_Pools.Subpools is
                end if;
          end;
 
-         --  Since subpool nodes are not allocated on the owner pool, they must
-         --  be explicitly destroyed.
-
-         Free (Curr_Ptr);
-
          Curr_Ptr := Next_Ptr;
       end loop;
 
@@ -446,7 +448,7 @@ package body System.Storage_Pools.Subpools is
       if Raised then
          Reraise_Occurrence (Ex_Occur);
       end if;
-   end Finalize;
+   end Finalize_Pool;
 
    ----------------------
    -- Finalize_Subpool --
@@ -454,9 +456,49 @@ package body System.Storage_Pools.Subpools is
 
    procedure Finalize_Subpool (Subpool : not null Subpool_Handle) is
    begin
+      --  Do nothing if the subpool was never used
+
+      if Subpool.Owner = null
+        or else Subpool.Node = null
+      then
+         return;
+      end if;
+
+      --  Clean up all controlled objects chained on the subpool's master
+
       Finalize (Subpool.Master);
+
+      --  Remove the subpool from its owner's list of subpools
+
+      Detach (Subpool.Node);
+
+      --  Destroy the associated doubly linked list node which was created in
+      --  Set_Pool_Of_Subpool.
+
+      Free (Subpool.Node);
    end Finalize_Subpool;
 
+   ----------------
+   -- Initialize --
+   ----------------
+
+   overriding procedure Initialize (Controller : in out Pool_Controller) is
+   begin
+      Initialize_Pool (Controller.Enclosing_Pool.all);
+   end Initialize;
+
+   ---------------------
+   -- Initialize_Pool --
+   ---------------------
+
+   procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
+   begin
+      --  The dummy head must point to itself in both directions
+
+      Pool.Subpools.Next := Pool.Subpools'Unchecked_Access;
+      Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
+   end Initialize_Pool;
+
    ---------------------
    -- Pool_Of_Subpool --
    ---------------------
@@ -478,15 +520,6 @@ package body System.Storage_Pools.Subpools is
       N_Ptr : SP_Node_Ptr;
 
    begin
-      if not Pool.Initialized then
-
-         --  The dummy head must point to itself in both directions
-
-         Pool.Subpools.Next := Pool.Subpools'Unchecked_Access;
-         Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
-         Pool.Initialized   := True;
-      end if;
-
       --  If the subpool is already owned, raise Program_Error. This is a
       --  direct violation of the RM rules.
 
@@ -502,13 +535,15 @@ package body System.Storage_Pools.Subpools is
            with "subpool creation after finalization started";
       end if;
 
-      --  Create a subpool node, decorate it and associate it with the subpool
-      --  list of Pool.
+      Subpool.Owner := Pool'Unchecked_Access;
 
-      N_Ptr := new SP_Node;
+      --  Create a subpool node and decorate it. Since this node is not
+      --  allocated on the owner's pool, it must be explicitly destroyed by
+      --  Finalize_And_Detach.
 
-      Subpool.Owner := Pool'Unchecked_Access;
+      N_Ptr := new SP_Node;
       N_Ptr.Subpool := Subpool;
+      Subpool.Node := N_Ptr;
 
       Attach (N_Ptr, Pool.Subpools'Unchecked_Access);
    end Set_Pool_Of_Subpool;
diff --git a/gcc/ada/s-stposu.ads b/gcc/ada/s-stposu.ads
index d8e58fb0797..bd268186926 100644
--- a/gcc/ada/s-stposu.ads
+++ b/gcc/ada/s-stposu.ads
@@ -33,6 +33,8 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Ada.Finalization;
+
 with System.Finalization_Masters;
 with System.Storage_Elements;
 
@@ -61,7 +63,8 @@ package System.Storage_Pools.Subpools is
       Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
       Alignment                : System.Storage_Elements.Storage_Count);
    --  Allocate an object described by Size_In_Storage_Elements and Alignment
-   --  on the default subpool of Pool.
+   --  on the default subpool of Pool. Controlled types allocated through this
+   --  routine will NOT be handled properly.
 
    procedure Allocate_From_Subpool
      (Pool                     : in out Root_Storage_Pool_With_Subpools;
@@ -126,50 +129,45 @@ package System.Storage_Pools.Subpools is
 
 private
    --  Model
-   --                           Pool_With_Subpools
-   --                 +----> +---------------------+ <----+
-   --                 |  +---------- Subpools      |      |
-   --                 |  |   +---------------------+      |
-   --                 |  |   :      User data      :      |
-   --                 |  |   '.....................'      |
-   --                 |  |                                |
-   --                 |  |    SP_Node       SP_Node       |
-   --                 |  +-> +-------+     +-------+      |
-   --                 |      | Prev  <-----> Prev  |      |
-   --                 |      +-------+     +-------+      |
-   --                 |      | Next  <---->| Next  |      |
-   --                 |      +-------+     +-------+      |
-   --                 |  +----Subpool|     |Subpool----+  |
-   --                 |  |   +-------+     +-------+   |  |
-   --                 |  |                             |  |
-   --                 |  |    Subpool       Subpool    |  |
-   --                 |  +-> +-------+     +-------+ <-+  |
-   --                 +------- Owner |     | Owner -------+
-   --                        +-------+     +-------+
-   --     +------------------- Master|     | Master---------------+
-   --     |                  +-------+     +-------+              |
-   --     |                  : User  :     : User  :              |
-   --     |                  : Data  :     : Data  :              |
-   --     |                  '.......'     '.......'              |
-   --     |                                                       |
-   --     |                           Heap                        |
-   --  .. | ..................................................... | ..
-   --  :  |                                                       |  :
-   --  :  |    Object    Object    Object               Object    |  :
-   --  :  +-> +------+  +------+  +------+             +------+ <-+  :
-   --  :      | Prev <--> Prev <--> Prev |             | Prev |      :
-   --  :      +------+  +------+  +------+             +------+      :
-   --  :      | Next <--> Next <--> Next |             | Next |      :
-   --  :      +------+  +------+  +------+             +------+      :
-   --  :      |  FA  |  |  FA  |  |  FA  |             |  FA  |      :
-   --  :      +------+  +------+  +------+             +------+      :
-   --  :      :      :  :      :  :      :             :      :      :
-   --  :      :      :  :      :  :      :             :      :      :
-   --  :      '......'  '......'  '......'             '......'      :
-   --  :                                                             :
-   --  '.............................................................'
+   --             Pool_With_Subpools     SP_Node    SP_Node    SP_Node
+   --       +-->+--------------------+   +-----+    +-----+    +-----+
+   --       |   |      Subpools -------->|  ------->|  ------->|  ------->
+   --       |   +--------------------+   +-----+    +-----+    +-----+
+   --       |   |Finalization_Started|<------  |<-------  |<-------  |<---
+   --       |   +--------------------+   +-----+    +-----+    +-----+
+   --       +--- Controller.Encl_Pool|   | nul |    |  +  |    |  +  |
+   --       |   +--------------------+   +-----+    +--|--+    +--:--+
+   --       |   :                    :    Dummy        |  ^       :
+   --       |   :                    :                 |  |       :
+   --       |                            Root_Subpool  V  |
+   --       |                            +-------------+  |
+   --       +-------------------------------- Owner    |  |
+   --               FM_Node   FM_Node    +-------------+  |
+   --               +-----+   +-----+<-- Master.Objects|  |
+   --            <------  |<------  |    +-------------+  |
+   --               +-----+   +-----+    |    Node -------+
+   --               |  ------>|  ----->  +-------------+
+   --               +-----+   +-----+    :             :
+   --               |ctrl |    Dummy     :             :
+   --               | obj |
+   --               +-----+
+   --
+   --  SP_Nodes are created on the heap. FM_Nodes and associated objects are
+   --  created on the pool_with_subpools.
+
+   type Any_Storage_Pool_With_Subpools_Ptr
+     is access all Root_Storage_Pool_With_Subpools'Class;
+   for Any_Storage_Pool_With_Subpools_Ptr'Storage_Size use 0;
+
+   --  A pool controller is a special controlled object which ensures the
+   --  proper initialization and finalization of the enclosing pool.
+
+   type Pool_Controller (Enclosing_Pool : Any_Storage_Pool_With_Subpools_Ptr)
+     is new Ada.Finalization.Limited_Controlled with null record;
 
    --  Subpool list types. Each pool_with_subpools contains a list of subpools.
+   --  This is an indirect doubly linked list since subpools are not supposed
+   --  to be allocatable by language design.
 
    type SP_Node;
    type SP_Node_Ptr is access all SP_Node;
@@ -180,19 +178,26 @@ private
       Subpool : Subpool_Handle := null;
    end record;
 
-   --  Root_Storage_Pool_With_Subpools internal structure
+   --  Root_Storage_Pool_With_Subpools internal structure. The type uses a
+   --  special controller to perform initialization and finalization actions
+   --  on itself. This is necessary because the end user of this package may
+   --  decide to override Initialize and Finalize, thus disabling the desired
+   --  behavior.
+
+   --          Pool_With_Subpools     SP_Node    SP_Node    SP_Node
+   --    +-->+--------------------+   +-----+    +-----+    +-----+
+   --    |   |      Subpools -------->|  ------->|  ------->|  ------->
+   --    |   +--------------------+   +-----+    +-----+    +-----+
+   --    |   |Finalization_Started|   :     :    :     :    :     :
+   --    |   +--------------------+
+   --    +--- Controller.Encl_Pool|
+   --        +--------------------+
+   --        :       End-user     :
+   --        :      components    :
 
    type Root_Storage_Pool_With_Subpools is abstract
      new Root_Storage_Pool with
    record
-      Initialized : Boolean := False;
-      pragma Atomic (Initialized);
-      --  Even though this type is derived from Limited_Controlled, overriding
-      --  Initialize would have no effect since the type is abstract. Routine
-      --  Set_Pool_Of_Subpool is tasked with the initialization of a pool with
-      --  subpools because it has to be called at some point. This flag is used
-      --  to prevent the resetting of the subpool chain.
-
       Subpools : aliased SP_Node;
       --  A doubly linked list of subpools
 
@@ -201,22 +206,47 @@ private
       --  A flag which prevents the creation of new subpools while the master
       --  pool is being finalized. The flag needs to be atomic because it is
       --  accessed without Lock_Task / Unlock_Task.
-   end record;
 
-   type Any_Storage_Pool_With_Subpools_Ptr
-     is access all Root_Storage_Pool_With_Subpools'Class;
-   for Any_Storage_Pool_With_Subpools_Ptr'Storage_Size use 0;
+      Controller : Pool_Controller
+                     (Root_Storage_Pool_With_Subpools'Unchecked_Access);
+      --  A component which ensures that the enclosing pool is initialized and
+      --  finalized at the appropriate places.
+   end record;
 
    --  A subpool is an abstraction layer which sits on top of a pool. It
    --  contains links to all controlled objects allocated on a particular
    --  subpool.
 
+   --        Pool_With_Subpools   SP_Node    SP_Node    SP_Node
+   --    +-->+----------------+   +-----+    +-----+    +-----+
+   --    |   |    Subpools ------>|  ------->|  ------->|  ------->
+   --    |   +----------------+   +-----+    +-----+    +-----+
+   --    |   :                :<------  |<-------  |<-------  |
+   --    |   :                :   +-----+    +-----+    +-----+
+   --    |                        |null |    |  +  |    |  +  |
+   --    |                        +-----+    +--|--+    +--:--+
+   --    |                                      |  ^       :
+   --    |                        Root_Subpool  V  |
+   --    |                        +-------------+  |
+   --    +---------------------------- Owner    |  |
+   --                             +-------------+  |
+   --                      .......... Master    |  |
+   --                             +-------------+  |
+   --                             |    Node -------+
+   --                             +-------------+
+   --                             :   End-user  :
+   --                             :  components :
+
    type Root_Subpool is abstract tagged limited record
       Owner : Any_Storage_Pool_With_Subpools_Ptr := null;
       --  A reference to the master pool_with_subpools
 
       Master : aliased System.Finalization_Masters.Finalization_Master;
       --  A collection of controlled objects
+
+      Node : SP_Node_Ptr := null;
+      --  A link to the doubly linked list node which contains the subpool.
+      --  This back pointer is used in subpool deallocation.
    end record;
 
    --  ??? Once Storage_Pools.Allocate_Any is removed, this should be renamed
@@ -224,32 +254,86 @@ private
 
    procedure Allocate_Any_Controlled
      (Pool            : in out Root_Storage_Pool'Class;
-      Context_Subpool : Subpool_Handle := null;
-      Context_Master  : Finalization_Masters.Finalization_Master_Ptr := null;
-      Fin_Address     : Finalization_Masters.Finalize_Address_Ptr := null;
+      Context_Subpool : Subpool_Handle;
+      Context_Master  : Finalization_Masters.Finalization_Master_Ptr;
+      Fin_Address     : Finalization_Masters.Finalize_Address_Ptr;
       Addr            : out System.Address;
       Storage_Size    : System.Storage_Elements.Storage_Count;
       Alignment       : System.Storage_Elements.Storage_Count;
-      Is_Controlled   : Boolean := True);
+      Is_Controlled   : Boolean;
+      On_Subpool      : Boolean);
    --  Compiler interface. This version of Allocate handles all possible cases,
-   --  either on a pool or a pool_with_subpools.
+   --  either on a pool or a pool_with_subpools, regardless of the controlled
+   --  status of the allocated object. Parameter usage:
+   --
+   --    * Pool - The pool associated with the access type. Pool can be any
+   --    derivation from Root_Storage_Pool, including a pool_with_subpools.
+   --
+   --    * Context_Subpool - The subpool handle name of an allocator. If no
+   --    subpool handle is present at the point of allocation, the actual
+   --    would be null.
+   --
+   --    * Context_Master - The finalization master associated with the access
+   --    type. If the access type's designated type is not controlled, the
+   --    actual would be null.
+   --
+   --    * Fin_Address - TSS routine Finalize_Address of the designated type.
+   --    If the designated type is not controlled, the actual would be null.
+   --
+   --    * Addr - The address of the allocated object.
+   --
+   --    * Storage_Size - The size of the allocated object.
+   --
+   --    * Alignment - The alignment of the allocated object.
+   --
+   --    * Is_Controlled - A flag which determines whether the allocated object
+   --    is controlled. When set to True, the machinery generates additional
+   --    data.
+   --
+   --    * On_Subpool - A flag which determines whether the a subpool handle
+   --    name is present at the point of allocation. This is used for error
+   --    diagnostics.
 
    procedure Deallocate_Any_Controlled
      (Pool          : in out Root_Storage_Pool'Class;
       Addr          : System.Address;
       Storage_Size  : System.Storage_Elements.Storage_Count;
       Alignment     : System.Storage_Elements.Storage_Count;
-      Is_Controlled : Boolean := True);
+      Is_Controlled : Boolean);
    --  Compiler interface. This version of Deallocate handles all possible
-   --  cases, either from a pool or a pool_with_subpools.
-
-   overriding procedure Finalize
-     (Pool : in out Root_Storage_Pool_With_Subpools);
+   --  cases, either from a pool or a pool_with_subpools, regardless of the
+   --  controlled status of the deallocated object. Parameter usage:
+   --
+   --    * Pool - The pool associated with the access type. Pool can be any
+   --    derivation from Root_Storage_Pool, including a pool_with_subpools.
+   --
+   --    * Addr - The address of the allocated object.
+   --
+   --    * Storage_Size - The size of the allocated object.
+   --
+   --    * Alignment - The alignment of the allocated object.
+   --
+   --    * Is_Controlled - A flag which determines whether the allocated object
+   --    is controlled. When set to True, the machinery generates additional
+   --    data.
+
+   overriding procedure Finalize (Controller : in out Pool_Controller);
+   --  Buffer routine, calls Finalize_Pool
+
+   procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools);
    --  Iterate over all subpools of Pool, detach them one by one and finalize
    --  their masters. This action first detaches a controlled object from a
    --  particular master, then invokes its Finalize_Address primitive.
 
    procedure Finalize_Subpool (Subpool : not null Subpool_Handle);
-   --  Finalize the master of a subpool
+   --  Finalize all controlled objects chained on Subpool's master. Remove the
+   --  subpool from its owner's list. Deallocate the associated doubly linked
+   --  list node.
+
+   overriding procedure Initialize (Controller : in out Pool_Controller);
+   --  Buffer routine, calls Initialize_Pool
+
+   procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools);
+   --  Setup the doubly linked list of subpools
 
 end System.Storage_Pools.Subpools;
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index a226c4810e7..ec108be4e47 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -1309,6 +1309,10 @@ package body Sem_Aggr is
       --  for discrete choices such as "L .. H => Expr" or the OTHERS choice).
       --  In this event we do not resolve Expr unless expansion is disabled.
       --  To know why, see the DELAYED COMPONENT RESOLUTION note above.
+      --
+      --  NOTE: In the case of "... => <>", we pass the in the
+      --  N_Component_Association node as Expr, since there is no Expression in
+      --  that case, and we need a Sloc for the error message.
 
       ---------
       -- Add --
@@ -1635,6 +1639,13 @@ package body Sem_Aggr is
                end if;
             end if;
 
+            --  If it's "... => <>", nothing to resolve
+
+            if Nkind (Expr) = N_Component_Association then
+               pragma Assert (Box_Present (Expr));
+               return Success;
+            end if;
+
             --  Ada 2005 (AI-231): Propagate the type to the nested aggregate.
             --  Required to check the null-exclusion attribute (if present).
             --  This value may be overridden later on.
@@ -1644,19 +1655,29 @@ package body Sem_Aggr is
             Resolution_OK := Resolve_Array_Aggregate
               (Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed);
 
-         --  Do not resolve the expressions of discrete or others choices
-         --  unless the expression covers a single component, or the expander
-         --  is inactive.
+         else
+
+            --  If it's "... => <>", nothing to resolve
 
-         elsif Single_Elmt
-           or else not Expander_Active
-           or else In_Spec_Expression
-         then
-            Analyze_And_Resolve (Expr, Component_Typ);
-            Check_Expr_OK_In_Limited_Aggregate (Expr);
-            Check_Non_Static_Context (Expr);
-            Aggregate_Constraint_Checks (Expr, Component_Typ);
-            Check_Unset_Reference (Expr);
+            if Nkind (Expr) = N_Component_Association then
+               pragma Assert (Box_Present (Expr));
+               return Success;
+            end if;
+
+            --  Do not resolve the expressions of discrete or others choices
+            --  unless the expression covers a single component, or the
+            --  expander is inactive.
+
+            if Single_Elmt
+              or else not Expander_Active
+              or else In_Spec_Expression
+            then
+               Analyze_And_Resolve (Expr, Component_Typ);
+               Check_Expr_OK_In_Limited_Aggregate (Expr);
+               Check_Non_Static_Context (Expr);
+               Aggregate_Constraint_Checks (Expr, Component_Typ);
+               Check_Unset_Reference (Expr);
+            end if;
          end if;
 
          if Raises_Constraint_Error (Expr)
@@ -1988,9 +2009,15 @@ package body Sem_Aggr is
 
                   --  Ada 2005 (AI-287): In case of default initialization of a
                   --  component the expander will generate calls to the
-                  --  corresponding initialization subprogram.
+                  --  corresponding initialization subprogram. We need to call
+                  --  Resolve_Aggr_Expr to check the rules about
+                  --  dimensionality.
 
-                  null;
+                  if not Resolve_Aggr_Expr (Assoc,
+                                            Single_Elmt => Single_Choice)
+                  then
+                     return Failure;
+                  end if;
 
                elsif not Resolve_Aggr_Expr (Expression (Assoc),
                                             Single_Elmt => Single_Choice)
@@ -2321,9 +2348,13 @@ package body Sem_Aggr is
 
                --  Ada 2005 (AI-287): In case of default initialization of a
                --  component the expander will generate calls to the
-               --  corresponding initialization subprogram.
+               --  corresponding initialization subprogram. We need to call
+               --  Resolve_Aggr_Expr to check the rules about
+               --  dimensionality.
 
-               null;
+               if not Resolve_Aggr_Expr (Assoc, Single_Elmt => False) then
+                  return Failure;
+               end if;
 
             elsif not Resolve_Aggr_Expr (Expression (Assoc),
                                          Single_Elmt => False)
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 1f076755db5..db7e37bbb36 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1471,6 +1471,7 @@ package body Sem_Ch13 is
 
                else
                   case A_Id is
+
                      --  For Pre/Post cases, insert immediately after the
                      --  entity declaration, since that is the required pragma
                      --  placement.
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 2c2d4c997fc..b8fd3e7533f 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -2348,7 +2348,7 @@ package body Sem_Ch6 is
          --  the proper back-annotations.
 
          if not Is_Frozen (Spec_Id)
-           and then (Expander_Active or ASIS_Mode)
+           and then (Expander_Active or else ASIS_Mode)
          then
             --  Force the generation of its freezing node to ensure proper
             --  management of access types in the backend.
@@ -6081,14 +6081,13 @@ package body Sem_Ch6 is
             end if;
 
             --  In the case of functions whose result type needs finalization,
-            --  add an extra formal of type Ada.Finalization.Heap_Management.
-            --  Finalization_Collection_Ptr.
+            --  add an extra formal which represents the finalization master.
 
-            if Needs_BIP_Collection (E) then
+            if Needs_BIP_Finalization_Master (E) then
                Discard :=
                  Add_Extra_Formal
-                   (E, RTE (RE_Finalization_Collection_Ptr),
-                    E, BIP_Formal_Suffix (BIP_Collection));
+                   (E, RTE (RE_Finalization_Master_Ptr),
+                    E, BIP_Formal_Suffix (BIP_Finalization_Master));
             end if;
 
             --  If the result type contains tasks, we have two extra formals: