Index: a-fihema.adb
===================================================================
--- a-fihema.adb	(revision 178181)
+++ a-fihema.adb	(working copy)
@@ -1,568 +0,0 @@
-------------------------------------------------------------------------------
---                                                                          --
---                         GNAT COMPILER COMPONENTS                         --
---                                                                          --
---     A D A . F I N A L I Z A T I O N . H E A P _ M A N A G E M E N T      --
---                                                                          --
---                                B o d y                                   --
---                                                                          --
---          Copyright (C) 2008-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.      --
---                                                                          --
-------------------------------------------------------------------------------
-
-with Ada.Exceptions;          use Ada.Exceptions;
-with Ada.Unchecked_Conversion;
-
-with System;                  use System;
-with System.Address_Image;
-with System.IO;               use System.IO;
---  ???with System.OS_Lib;
---  Breaks ravenscar runtimes
-with System.Soft_Links;       use System.Soft_Links;
-with System.Storage_Elements; use System.Storage_Elements;
-with System.Storage_Pools;    use System.Storage_Pools;
-
-package body Ada.Finalization.Heap_Management is
-
-   Debug : constant Boolean := False;
-   --  True for debugging printouts.
-
-   Header_Size : constant Storage_Count  := Node'Size / Storage_Unit;
-   --  Size of the header in bytes. Added to Storage_Size requested by
-   --  Allocate/Deallocate to determine the Storage_Size passed to the
-   --  underlying pool.
-
-   function Address_To_Node_Ptr is
-     new Ada.Unchecked_Conversion (Address, Node_Ptr);
-
-   procedure Attach (N : Node_Ptr; L : Node_Ptr);
-   --  Prepend a node to a list
-
-   procedure Detach (N : Node_Ptr);
-   --  Unhook a node from an arbitrary list
-
-   procedure Fin_Assert (Condition : Boolean; Message : String);
-   --  Asserts that the condition is True. Used instead of pragma Assert in
-   --  delicate places where raising an exception would cause re-invocation of
-   --  finalization. Instead of raising an exception, aborts the whole process.
-
-   function Is_Empty (Objects : Node_Ptr) return Boolean;
-   --  True if the Objects list is empty
-
-   ----------------
-   -- Fin_Assert --
-   ----------------
-
-   procedure Fin_Assert (Condition : Boolean; Message : String) is
-
-      procedure Fail;
-      --  Use a separate procedure to make it easy to set a breakpoint here.
-
-      ----------
-      -- Fail --
-      ----------
-
-      procedure Fail is
-      begin
-         Put_Line ("Heap_Management: Fin_Assert failed: " & Message);
-         --  ???OS_Lib.OS_Abort;
-         --  Breaks ravenscar runtimes
-      end Fail;
-
-   --  Start of processing for Fin_Assert
-
-   begin
-      if not Condition then
-         Fail;
-      end if;
-   end Fin_Assert;
-
-   ---------------------------
-   -- Add_Offset_To_Address --
-   ---------------------------
-
-   function Add_Offset_To_Address
-     (Addr   : System.Address;
-      Offset : System.Storage_Elements.Storage_Offset) return System.Address
-   is
-   begin
-      return System.Storage_Elements."+" (Addr, Offset);
-   end Add_Offset_To_Address;
-
-   --------------
-   -- Allocate --
-   --------------
-
-   procedure Allocate
-     (Collection   : in out Finalization_Collection;
-      Addr         : out System.Address;
-      Storage_Size : System.Storage_Elements.Storage_Count;
-      Alignment    : System.Storage_Elements.Storage_Count;
-      Needs_Header : Boolean := True)
-   is
-   begin
-      --  Allocation of an object with controlled parts
-
-      if Needs_Header then
-
-         --  Do not allow the allocation of controlled objects while the
-         --  associated collection is being finalized.
-
-         if Collection.Finalization_Started then
-            raise Program_Error with "allocation after finalization started";
-         end if;
-
-         declare
-            Header_Offset : Storage_Offset;
-            N_Addr        : Address;
-            N_Ptr         : Node_Ptr;
-
-         begin
-            --  Offset from the header to the actual object. The header is
-            --  just in front of the object. There may be padding space before
-            --  the header.
-
-            if Alignment > Header_Size then
-               Header_Offset := Alignment;
-            else
-               Header_Offset := Header_Size;
-            end if;
-
-            --  Use the underlying pool to allocate enough space for the object
-            --  and the list header. The returned address points to the list
-            --  header. If locking is necessary, it will be done by the
-            --  underlying pool.
-
-            Allocate
-              (Collection.Base_Pool.all,
-               N_Addr,
-               Storage_Size + Header_Offset,
-               Alignment);
-
-            --  Map the allocated memory into a Node record. This converts the
-            --  top of the allocated bits into a list header.
-
-            N_Ptr := Address_To_Node_Ptr
-              (N_Addr + Header_Offset - Header_Size);
-            Attach (N_Ptr, Collection.Objects'Unchecked_Access);
-
-            --  Move the address from Prev to the start of the object. This
-            --  operation effectively hides the list header.
-
-            Addr := N_Addr + Header_Offset;
-         end;
-
-      --  Allocation of a non-controlled object
-
-      else
-         Allocate
-           (Collection.Base_Pool.all,
-            Addr,
-            Storage_Size,
-            Alignment);
-      end if;
-
-      pragma Assert (Addr mod Alignment = 0);
-   end Allocate;
-
-   ------------
-   -- Attach --
-   ------------
-
-   procedure Attach (N : Node_Ptr; L : Node_Ptr) is
-   begin
-      Lock_Task.all;
-
-      L.Next.Prev := N;
-      N.Next := L.Next;
-      L.Next := N;
-      N.Prev := L;
-
-      Unlock_Task.all;
-
-      --  Note: no need to unlock in case of exceptions; the above code cannot
-      --  raise any.
-
-   end Attach;
-
-   ---------------
-   -- Base_Pool --
-   ---------------
-
-   function Base_Pool
-     (Collection : Finalization_Collection) return Any_Storage_Pool_Ptr
-   is
-   begin
-      return Collection.Base_Pool;
-   end Base_Pool;
-
-   ----------------
-   -- Deallocate --
-   ----------------
-
-   procedure Deallocate
-     (Collection   : in out Finalization_Collection;
-      Addr         : System.Address;
-      Storage_Size : System.Storage_Elements.Storage_Count;
-      Alignment    : System.Storage_Elements.Storage_Count;
-      Has_Header   : Boolean := True)
-   is
-      pragma Assert (Addr mod Alignment = 0);
-   begin
-      --  Deallocation of an object with controlled parts
-
-      if Has_Header then
-         declare
-            Header_Offset : Storage_Offset;
-            N_Addr        : Address;
-            N_Ptr         : Node_Ptr;
-
-         begin
-            --  Offset from the header to the actual object.
-
-            if Alignment > Header_Size then
-               Header_Offset := Alignment;
-            else
-               Header_Offset := Header_Size;
-            end if;
-
-            --  Converts from the object to the list header
-
-            N_Ptr := Address_To_Node_Ptr (Addr - Header_Size);
-            Detach (N_Ptr);
-
-            --  Converts the bits preceding the object the block address.
-
-            N_Addr := Addr - Header_Offset;
-
-            --  Use the underlying pool to destroy the object along with the
-            --  list header.
-
-            Deallocate
-              (Collection.Base_Pool.all,
-               N_Addr,
-               Storage_Size + Header_Size,
-               Alignment);
-         end;
-
-      --  Deallocation of a non-controlled object
-
-      else
-         Deallocate
-           (Collection.Base_Pool.all,
-            Addr,
-            Storage_Size,
-            Alignment);
-      end if;
-   end Deallocate;
-
-   ------------
-   -- Detach --
-   ------------
-
-   procedure Detach (N : Node_Ptr) is
-   begin
-      pragma Debug (Fin_Assert (N /= null, "Detach null"));
-
-      Lock_Task.all;
-
-      if N.Next = null then
-         pragma Assert (N.Prev = null);
-
-      else
-         N.Prev.Next := N.Next;
-         N.Next.Prev := N.Prev;
-         N.Next := null;
-         N.Prev := null;
-      end if;
-
-      Unlock_Task.all;
-
-      --  Note: no need to unlock in case of exceptions; the above code cannot
-      --  raise any.
-
-   end Detach;
-
-   --------------
-   -- Finalize --
-   --------------
-
-   overriding procedure Finalize
-     (Collection : in out Finalization_Collection)
-   is
-      Ex_Occur : Exception_Occurrence;
-      Raised   : Boolean := False;
-
-   begin
-      if Debug then
-         Put_Line ("-->Heap_Management: ");
-         pcol (Collection);
-      end if;
-
-      --  Set Finalization_Started to prevent any allocations of objects with
-      --  controlled parts during finalization. The associated access type is
-      --  about to go out of scope; Finalization_Started is never again
-      --  modified.
-
-      if Collection.Finalization_Started then
-
-         --  ???Needed for shared libraries
-
-         return;
-      end if;
-
-      pragma Debug (Fin_Assert (not Collection.Finalization_Started,
-                                "Finalize: already started"));
-      Collection.Finalization_Started := True;
-
-      --  For each object in the Objects list, detach it, and finalize it. Note
-      --  that other tasks can be doing Unchecked_Deallocations at the same
-      --  time, so we need to beware of race conditions.
-
-      while not Is_Empty (Collection.Objects'Unchecked_Access) loop
-
-         declare
-            Node : constant Node_Ptr := Collection.Objects.Next;
-         begin
-            --  Remove the current node from the list first, in case some other
-            --  task is simultaneously doing Unchecked_Deallocation on this
-            --  object. Detach does Lock_Task. Note that we can't Lock_Task
-            --  during Finalize_Address, because finalization can do pretty
-            --  much anything.
-
-            Detach (Node);
-
-            --  ??? Kludge: Don't do anything until the proper place to set
-            --  primitive Finalize_Address has been determined.
-
-            if Collection.Finalize_Address /= null then
-               declare
-                  Object_Address : constant Address :=
-                                     Node.all'Address + Header_Size;
-                  --  Get address of object from address of header
-
-               begin
-                  Collection.Finalize_Address (Object_Address);
-               exception
-                  when Fin_Except : others =>
-                     if not Raised then
-                        Raised := True;
-                        Save_Occurrence (Ex_Occur, Fin_Except);
-                     end if;
-               end;
-            end if;
-         end;
-      end loop;
-
-      if Debug then
-         Put_Line ("<--Heap_Management: ");
-         pcol (Collection);
-      end if;
-
-      --  If the finalization of a particular node raised an exception, reraise
-      --  it after the remainder of the list has been finalized.
-
-      if Raised then
-         if Debug then
-            Put_Line ("Heap_Management: reraised");
-         end if;
-
-         Reraise_Occurrence (Ex_Occur);
-      end if;
-   end Finalize;
-
-   ----------------
-   -- Initialize --
-   ----------------
-
-   overriding procedure Initialize
-     (Collection : in out Finalization_Collection)
-   is
-   begin
-      --  The dummy head must point to itself in both directions
-
-      Collection.Objects.Next := Collection.Objects'Unchecked_Access;
-      Collection.Objects.Prev := Collection.Objects'Unchecked_Access;
-      pragma Assert (Is_Empty (Collection.Objects'Unchecked_Access));
-   end Initialize;
-
-   --------------
-   -- Is_Empty --
-   --------------
-
-   function Is_Empty (Objects : Node_Ptr) return Boolean is
-   begin
-      pragma Debug
-        (Fin_Assert ((Objects.Next = Objects) = (Objects.Prev = Objects),
-                     "Is_Empty"));
-      return Objects.Next = Objects;
-   end Is_Empty;
-
-   ----------
-   -- pcol --
-   ----------
-
-   procedure pcol (Collection : Finalization_Collection) is
-      Head      : constant Node_Ptr := Collection.Objects'Unrestricted_Access;
-      --  "Unrestricted", because we are getting access-to-variable of a
-      --  constant! Normally worrisome, this is OK for debugging code.
-
-      Head_Seen : Boolean := False;
-      N_Ptr     : Node_Ptr;
-
-   begin
-      --  Output the basic contents of the collection
-
-      --    Collection: 0x123456789
-      --    Base_Pool : null <or> 0x123456789
-      --    Fin_Addr  : null <or> 0x123456789
-      --    Fin_Start : TRUE <or> FALSE
-
-      Put ("Collection: ");
-      Put_Line (Address_Image (Collection'Address));
-
-      Put ("Base_Pool : ");
-
-      if Collection.Base_Pool = null then
-         Put_Line (" null");
-      else
-         Put_Line (Address_Image (Collection.Base_Pool'Address));
-      end if;
-
-      Put ("Fin_Addr  : ");
-
-      if Collection.Finalize_Address = null then
-         Put_Line ("null");
-      else
-         Put_Line (Address_Image (Collection.Finalize_Address'Address));
-      end if;
-
-      Put ("Fin_Start : ");
-      Put_Line (Collection.Finalization_Started'Img);
-
-      --  Output all chained elements. The format is the following:
-
-      --    ^ <or> ? <or> null
-      --    |Header: 0x123456789 (dummy head)
-      --    |  Prev: 0x123456789
-      --    |  Next: 0x123456789
-      --    V
-
-      --  ^ - the current element points back to the correct element
-      --  ? - the current element points back to an erroneous element
-      --  n - the current element points back to null
-
-      --  Header - the address of the list header
-      --  Prev   - the address of the list header which the current element
-      --         - points back to
-      --  Next   - the address of the list header which the current element
-      --         - points to
-      --  (dummy head) - present if dummy head
-
-      N_Ptr := Head;
-      while N_Ptr /= null loop -- Should never be null; we being defensive
-         Put_Line ("V");
-
-         --  We see the head initially; we want to exit when we see the head a
-         --  SECOND time.
-
-         if N_Ptr = Head then
-            exit when Head_Seen;
-
-            Head_Seen := True;
-         end if;
-
-         --  The current element is null. This should never happen since the
-         --  list is circular.
-
-         if N_Ptr.Prev = null then
-            Put_Line ("null (ERROR)");
-
-         --  The current element points back to the correct element
-
-         elsif N_Ptr.Prev.Next = N_Ptr then
-            Put_Line ("^");
-
-         --  The current element points to an erroneous element
-
-         else
-            Put_Line ("? (ERROR)");
-         end if;
-
-         --  Output the header and fields
-
-         Put ("|Header: ");
-         Put (Address_Image (N_Ptr.all'Address));
-
-         --  Detect the dummy head
-
-         if N_Ptr = Head then
-            Put_Line (" (dummy head)");
-         else
-            Put_Line ("");
-         end if;
-
-         Put ("|  Prev: ");
-
-         if N_Ptr.Prev = null then
-            Put_Line ("null");
-         else
-            Put_Line (Address_Image (N_Ptr.Prev.all'Address));
-         end if;
-
-         Put ("|  Next: ");
-
-         if N_Ptr.Next = null then
-            Put_Line ("null");
-         else
-            Put_Line (Address_Image (N_Ptr.Next.all'Address));
-         end if;
-
-         N_Ptr := N_Ptr.Next;
-      end loop;
-   end pcol;
-
-   ------------------------------
-   -- Set_Finalize_Address_Ptr --
-   ------------------------------
-
-   procedure Set_Finalize_Address_Ptr
-     (Collection : in out Finalization_Collection;
-      Proc_Ptr   : Finalize_Address_Ptr)
-   is
-   begin
-      Collection.Finalize_Address := Proc_Ptr;
-   end Set_Finalize_Address_Ptr;
-
-   --------------------------
-   -- Set_Storage_Pool_Ptr --
-   --------------------------
-
-   procedure Set_Storage_Pool_Ptr
-     (Collection : in out Finalization_Collection;
-      Pool_Ptr   : Any_Storage_Pool_Ptr)
-   is
-   begin
-      Collection.Base_Pool := Pool_Ptr;
-   end Set_Storage_Pool_Ptr;
-
-end Ada.Finalization.Heap_Management;
Index: a-fihema.ads
===================================================================
--- a-fihema.ads	(revision 178181)
+++ a-fihema.ads	(working copy)
@@ -1,161 +0,0 @@
-------------------------------------------------------------------------------
---                                                                          --
---                         GNAT COMPILER COMPONENTS                         --
---                                                                          --
---     A D A . F I N A L I Z A T I O N . H E A P _ M A N A G E M E N T      --
---                                                                          --
---                                S p e c                                   --
---                                                                          --
---          Copyright (C) 2008-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.      --
---                                                                          --
-------------------------------------------------------------------------------
-
-with System;
-with System.Storage_Elements;
-with System.Storage_Pools;
-
-package Ada.Finalization.Heap_Management is
-
-   --  A reference to any derivation of Root_Storage_Pool. Since this type may
-   --  not be used to allocate objects, its storage size is zero.
-
-   type Any_Storage_Pool_Ptr is
-     access System.Storage_Pools.Root_Storage_Pool'Class;
-   for Any_Storage_Pool_Ptr'Storage_Size use 0;
-
-   --  ??? Comment needed on overall mechanism
-
-   type Finalization_Collection is
-     new Ada.Finalization.Limited_Controlled with private;
-
-   type Finalization_Collection_Ptr is access all Finalization_Collection;
-   for Finalization_Collection_Ptr'Storage_Size use 0;
-
-   --  A reference used to describe primitive Finalize_Address
-
-   type Finalize_Address_Ptr is access procedure (Obj : System.Address);
-
-   --  Since RTSfind cannot contain names of the form RE_"+", the following
-   --  routine serves as a wrapper around System.Storage_Elements."+".
-
-   function Add_Offset_To_Address
-     (Addr   : System.Address;
-      Offset : System.Storage_Elements.Storage_Offset) return System.Address;
-
-   procedure Allocate
-     (Collection   : in out Finalization_Collection;
-      Addr         : out System.Address;
-      Storage_Size : System.Storage_Elements.Storage_Count;
-      Alignment    : System.Storage_Elements.Storage_Count;
-      Needs_Header : Boolean := True);
-   --  Allocate a chunk of memory described by Storage_Size and Alignment on
-   --  Collection's underlying storage pool. Return the address of the chunk.
-   --  The routine creates a list header which precedes the chunk of memory if
-   --  Needs_Header is True. If allocated, the header is attached to the
-   --  Collection's objects. The interface to this routine is provided by
-   --  Build_Allocate_Deallocate_Proc.
-
-   function Base_Pool
-     (Collection : Finalization_Collection) return Any_Storage_Pool_Ptr;
-   --  Return a reference to the underlying storage pool of Collection
-
-   procedure Deallocate
-     (Collection   : in out Finalization_Collection;
-      Addr         : System.Address;
-      Storage_Size : System.Storage_Elements.Storage_Count;
-      Alignment    : System.Storage_Elements.Storage_Count;
-      Has_Header   : Boolean := True);
-   --  Deallocate a chunk of memory described by Storage_Size and Alignment
-   --  from Collection's underlying storage pool. The beginning of the memory
-   --  chunk is designated by Addr. The routine detaches and destroys the
-   --  preceding list header if flag Has_Header is set. The interface to this
-   --  routine is provided by Build_Allocate_Deallocate_Proc.
-
-   overriding procedure Finalize
-     (Collection : in out Finalization_Collection);
-   --  Traverse objects of Collection, invoking Finalize_Address on each one
-
-   overriding procedure Initialize
-     (Collection : in out Finalization_Collection);
-   --  Initialize the finalization list to empty
-
-   procedure Set_Finalize_Address_Ptr
-     (Collection : in out Finalization_Collection;
-      Proc_Ptr   : Finalize_Address_Ptr);
-   --  Set the finalization address routine of a finalization collection
-
-   procedure Set_Storage_Pool_Ptr
-     (Collection : in out Finalization_Collection;
-      Pool_Ptr   : Any_Storage_Pool_Ptr);
-   --  Set the underlying storage pool of a finalization collection
-
-private
-   --  Homogeneous collection types
-
-   type Node;
-   type Node_Ptr is access all Node;
-   pragma No_Strict_Aliasing (Node_Ptr);
-
-   --  The following record type should really be limited, but we can see the
-   --  full view of Limited_Controlled, which is NOT limited. Note that default
-   --  initialization does not happen for this type (the pointers will not be
-   --  automatically set to null), because of the games we're playing with
-   --  address arithmetic. Code in the body assumes that the size of
-   --  this record is a power of 2 to deal with alignment.
-
-   type Node is record
-      Prev : Node_Ptr;
-      Next : Node_Ptr;
-   end record;
-
-   type Finalization_Collection is
-     new Ada.Finalization.Limited_Controlled with
-   record
-      Base_Pool : Any_Storage_Pool_Ptr;
-      --  All objects and node headers are allocated on this underlying pool;
-      --  the collection is simply a wrapper around it.
-
-      Objects : aliased Node;
-      --  The head of a doubly linked list containing all allocated objects
-      --  with controlled parts that still exist (Unchecked_Deallocation has
-      --  not been done on them).
-
-      Finalize_Address : Finalize_Address_Ptr;
-      --  A reference to a routine that finalizes an object denoted by its
-      --  address. The collection must be homogeneous since the same routine
-      --  will be invoked for every allocated object when the pool is
-      --  finalized.
-
-      Finalization_Started : Boolean := False;
-      pragma Atomic (Finalization_Started);
-      --  When the finalization of a collection takes place, any allocations of
-      --  objects with controlled or protected parts on the same collection are
-      --  prohibited and the action must raise Program_Error. This needs to be
-      --  atomic, because it is accessed without Lock_Task/Unlock_Task. See
-      --  RM-4.8(10.2/2).
-   end record;
-
-   procedure pcol (Collection : Finalization_Collection);
-   --  Output the contents of a collection in a readable form. Intended for
-   --  debugging purposes.
-
-end Ada.Finalization.Heap_Management;
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 178161)
+++ sem_ch3.adb	(working copy)
@@ -1353,7 +1353,7 @@
       Set_Has_Task (T, False);
       Set_Has_Controlled_Component (T, False);
 
-      --  Initialize Associated_Collection explicitly to Empty, to avoid
+      --  Initialize field Finalization_Master explicitly to Empty, to avoid
       --  problems where an incomplete view of this entity has been previously
       --  established by a limited with and an overlaid version of this field
       --  (Stored_Constraint) was initialized for the incomplete view.
@@ -1361,10 +1361,10 @@
       --  This reset is performed in most cases except where the access type
       --  has been created for the purposes of allocating or deallocating a
       --  build-in-place object. Such access types have explicitly set pools
-      --  and collections.
+      --  and finalization masters.
 
       if No (Associated_Storage_Pool (T)) then
-         Set_Associated_Collection (T, Empty);
+         Set_Finalization_Master (T, Empty);
       end if;
 
       --  Ada 2005 (AI-231): Propagate the null-excluding and access-constant
Index: impunit.adb
===================================================================
--- impunit.adb	(revision 178155)
+++ impunit.adb	(working copy)
@@ -111,6 +111,7 @@
      "a-titest",    -- Ada.Text_IO.Text_Streams
      "a-unccon",    -- Ada.Unchecked_Conversion
      "a-uncdea",    -- Ada.Unchecked_Deallocation
+     "a-undesu",    -- Ada.Unchecked_Deallocate_Subpool
      "a-witeio",    -- Ada.Wide_Text_IO
      "a-wtcoio",    -- Ada.Wide_Text_IO.Complex_IO
      "a-wtedit",    -- Ada.Wide_Text_IO.Editing
@@ -339,6 +340,7 @@
      "s-rpc   ",    -- System.Rpc
      "s-stoele",    -- System.Storage_Elements
      "s-stopoo",    -- System.Storage_Pools
+     "s-stposu",    -- System.Storage_Pools.Subpools
 
    --------------------------------------
    -- GNAT Defined Additions to System --
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb	(revision 178155)
+++ exp_ch7.adb	(working copy)
@@ -431,8 +431,8 @@
    --  whether the inner logic should be dictated by state counters.
 
    function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
-   --  Subsidiary to Make_Finalize_Address_Body and Make_Deep_Array_Body.
-   --  Generate the following statements:
+   --  Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
+   --  Make_Deep_Record_Body. Generate the following statements:
    --
    --    declare
    --       type Acc_Typ is access all Typ;
@@ -797,11 +797,11 @@
                   Parameter_Associations => Actuals)))));
    end Build_Exception_Handler;
 
-   -----------------------------------
-   -- Build_Finalization_Collection --
-   -----------------------------------
+   -------------------------------
+   -- Build_Finalization_Master --
+   -------------------------------
 
-   procedure Build_Finalization_Collection
+   procedure Build_Finalization_Master
      (Typ        : Entity_Id;
       Ins_Node   : Node_Id := Empty;
       Encl_Scope : Entity_Id := Empty)
@@ -837,7 +837,7 @@
          return False;
       end In_Deallocation_Instance;
 
-   --  Start of processing for Build_Finalization_Collection
+   --  Start of processing for Build_Finalization_Master
 
    begin
       --  Certain run-time configurations and targets do not provide support
@@ -847,16 +847,13 @@
          return;
 
       --  Various machinery such as freezing may have already created a
-      --  collection.
+      --  finalization master.
 
-      elsif Present (Associated_Collection (Typ)) then
+      elsif Present (Finalization_Master (Typ)) then
          return;
 
       --  Do not process types that return on the secondary stack
 
-      --  ??? The need for a secondary stack should be revisited and perhaps
-      --  changed.
-
       elsif Present (Associated_Storage_Pool (Typ))
         and then Is_RTE (Associated_Storage_Pool (Typ), RE_SS_Pool)
       then
@@ -875,7 +872,7 @@
          return;
 
       --  Ignore the general use of anonymous access types unless the context
-      --  requires a collection.
+      --  requires a finalization master.
 
       elsif Ekind (Typ) = E_Anonymous_Access_Type
         and then No (Ins_Node)
@@ -883,7 +880,7 @@
          return;
 
       --  Do not process non-library access types when restriction No_Nested_
-      --  Finalization is in effect since collections are controlled objects.
+      --  Finalization is in effect since masters are controlled objects.
 
       elsif Restriction_Active (No_Nested_Finalization)
         and then not Is_Library_Level_Entity (Typ)
@@ -901,87 +898,85 @@
       end if;
 
       declare
-         Loc     : constant Source_Ptr := Sloc (Typ);
-         Actions : constant List_Id := New_List;
-         Coll_Id : Entity_Id;
-         Pool_Id : Entity_Id;
+         Loc        : constant Source_Ptr := Sloc (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 : Finalization_Collection;
+         --    Fnn : aliased Finalization_Master;
 
-         --  Source access types use fixed names for their collections since
-         --  the collection is inserted only once in the same source unit and
-         --  there is no possible name overlap. Internally-generated access
-         --  types on the other hand use temporaries as collection names due
-         --  to possible name collisions.
+         --  Source access types use fixed master names since the master is
+         --  inserted in the same source unit only once. The only exception to
+         --  this are instances using the same access type as generic actual.
 
-         if Comes_From_Source (Typ) then
-            Coll_Id :=
+         if Comes_From_Source (Ptr_Typ)
+           and then not Inside_A_Generic
+         then
+            Fin_Mas_Id :=
               Make_Defining_Identifier (Loc,
-                Chars => New_External_Name (Chars (Typ), "FC"));
+                Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
+
+         --  Internally generated access types use temporaries as their names
+         --  due to possible collision with identical names coming from other
+         --  packages.
+
          else
-            Coll_Id := Make_Temporary (Loc, 'F');
+            Fin_Mas_Id := Make_Temporary (Loc, 'F');
          end if;
 
          Append_To (Actions,
            Make_Object_Declaration (Loc,
-             Defining_Identifier => Coll_Id,
+             Defining_Identifier => Fin_Mas_Id,
+             Aliased_Present     => True,
              Object_Definition   =>
-               New_Reference_To (RTE (RE_Finalization_Collection), Loc)));
+               New_Reference_To (RTE (RE_Finalization_Master), Loc)));
 
          --  Storage pool selection and attribute decoration of the generated
-         --  collection. Since .NET/JVM compilers do not support pools, this
-         --  step is skipped.
+         --  master. Since .NET/JVM compilers do not support pools, this step
+         --  is skipped.
 
          if VM_Target = No_VM then
 
             --  If the access type has a user-defined pool, use it as the base
             --  storage medium for the finalization pool.
 
-            if Present (Associated_Storage_Pool (Typ)) then
-               Pool_Id := Associated_Storage_Pool (Typ);
+            if Present (Associated_Storage_Pool (Ptr_Typ)) then
+               Pool_Id := Associated_Storage_Pool (Ptr_Typ);
 
-            --  Access subtypes must use the storage pool of their base type
-
-            elsif Ekind (Typ) = E_Access_Subtype then
-               declare
-                  Base_Typ : constant Entity_Id := Base_Type (Typ);
-
-               begin
-                  if No (Associated_Storage_Pool (Base_Typ)) then
-                     Pool_Id := Get_Global_Pool_For_Access_Type (Base_Typ);
-                     Set_Associated_Storage_Pool (Base_Typ, Pool_Id);
-                  else
-                     Pool_Id := Associated_Storage_Pool (Base_Typ);
-                  end if;
-               end;
-
             --  The default choice is the global pool
 
             else
-               Pool_Id := Get_Global_Pool_For_Access_Type (Typ);
-               Set_Associated_Storage_Pool (Typ, Pool_Id);
+               Pool_Id := Get_Global_Pool_For_Access_Type (Ptr_Typ);
+               Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
             end if;
 
             --  Generate:
-            --    Set_Storage_Pool_Ptr (Fnn, Pool_Id'Unchecked_Access);
+            --    Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);
 
             Append_To (Actions,
               Make_Procedure_Call_Statement (Loc,
                 Name                   =>
-                  New_Reference_To (RTE (RE_Set_Storage_Pool_Ptr), Loc),
+                  New_Reference_To (RTE (RE_Set_Base_Pool), Loc),
                 Parameter_Associations => New_List (
-                  New_Reference_To (Coll_Id, Loc),
+                  New_Reference_To (Fin_Mas_Id, Loc),
                   Make_Attribute_Reference (Loc,
                     Prefix         => New_Reference_To (Pool_Id, Loc),
                     Attribute_Name => Name_Unrestricted_Access))));
          end if;
 
-         Set_Associated_Collection (Typ, Coll_Id);
+         Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
 
-         --  A finalization collection created for an anonymous access type
-         --  must be inserted before a context-dependent node.
+         --  A finalization master created for an anonymous access type must be
+         --  inserted before a context-dependent node.
 
          if Present (Ins_Node) then
             Push_Scope (Encl_Scope);
@@ -1024,12 +1019,12 @@
             Append_Freeze_Actions (Typ, Actions);
 
          --  If there's a pool created locally for the access type, then we
-         --  need to ensure that the collection gets created after the pool
-         --  object, because otherwise we can have a forward reference, so
-         --  we force the collection actions to be inserted and analyzed after
-         --  the pool entity. Note that both the access type and its designated
-         --  type may have already been frozen and had their freezing actions
-         --  analyzed at this point. (This seems a little unclean.???)
+         --  need to ensure that the master gets created after the pool object,
+         --  because otherwise we can have a forward reference, so we force the
+         --  master actions to be inserted and analyzed after the pool entity.
+         --  Note that both the access type and its designated type may have
+         --  already been frozen and had their freezing actions analyzed at
+         --  this point. (This seems a little unclean.???)
 
          elsif VM_Target = No_VM
            and then Scope (Pool_Id) = Scope (Typ)
@@ -1040,7 +1035,7 @@
             Insert_Actions (Parent (Typ), Actions);
          end if;
       end;
-   end Build_Finalization_Collection;
+   end Build_Finalization_Master;
 
    ---------------------
    -- Build_Finalizer --
@@ -1933,15 +1928,15 @@
                end if;
 
             --  Inspect the freeze node of an access-to-controlled type and
-            --  look for a delayed finalization collection. This case arises
-            --  when the freeze actions are inserted at a later time than the
+            --  look for a delayed finalization master. This case arises when
+            --  the freeze actions are inserted at a later time than the
             --  expansion of the context. Since Build_Finalizer is never called
-            --  on a single construct twice, the collection will be ultimately
+            --  on a single construct twice, the master will be ultimately
             --  left out and never finalized. This is also needed for freeze
             --  actions of designated types themselves, since in some cases the
-            --  finalization collection is associated with a designated type's
+            --  finalization master is associated with a designated type's
             --  freeze node rather than that of the access type (see handling
-            --  for freeze actions in Build_Finalization_Collection).
+            --  for freeze actions in Build_Finalization_Master).
 
             elsif Nkind (Decl) = N_Freeze_Entity
               and then Present (Actions (Decl))
@@ -1958,12 +1953,12 @@
 
                   --  Freeze nodes are considered to be identical to packages
                   --  and blocks in terms of nesting. The difference is that
-                  --  a finalization collection created inside the freeze node
-                  --  is at the same nesting level as the node itself.
+                  --  a finalization master created inside the freeze node is
+                  --  at the same nesting level as the node itself.
 
                   Process_Declarations (Actions (Decl), Preprocess);
 
-                  --  The freeze node contains a finalization collection
+                  --  The freeze node contains a finalization master
 
                   if Preprocess
                     and then Top_Level
@@ -2086,11 +2081,12 @@
          --  following cleanup code:
          --
          --    if BIPallocfrom > Secondary_Stack'Pos
-         --      and then BIPcollection /= null
+         --      and then BIPfinalizationmaster /= null
          --    then
          --       declare
          --          type Ptr_Typ is access Obj_Typ;
-         --          for Ptr_Typ'Storage_Pool use Base_Pool (BIPcollection);
+         --          for Ptr_Typ'Storage_Pool
+         --            use Base_Pool (BIPfinalizationmaster);
          --
          --       begin
          --          Free (Ptr_Typ (Temp));
@@ -2118,12 +2114,13 @@
          function Build_BIP_Cleanup_Stmts
            (Func_Id : Entity_Id) return Node_Id
          is
-            Collect : constant Entity_Id :=
-                        Build_In_Place_Formal (Func_Id, BIP_Collection);
-            Decls   : constant List_Id := New_List;
-            Obj_Typ : constant Entity_Id := Etype (Func_Id);
-            Temp_Id : constant Entity_Id :=
-                        Entity (Prefix (Name (Parent (Obj_Id))));
+            Decls      : constant List_Id := New_List;
+            Fin_Mas_Id : constant Entity_Id :=
+                           Build_In_Place_Formal
+                             (Func_Id, BIP_Finalization_Master);
+            Obj_Typ    : constant Entity_Id := Etype (Func_Id);
+            Temp_Id    : constant Entity_Id :=
+                           Entity (Prefix (Name (Parent (Obj_Id))));
 
             Cond      : Node_Id;
             Free_Blk  : Node_Id;
@@ -2133,7 +2130,7 @@
 
          begin
             --  Generate:
-            --    Pool_Id renames Base_Pool (BIPcollection.all).all;
+            --    Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
 
             Pool_Id := Make_Temporary (Loc, 'P');
 
@@ -2150,10 +2147,10 @@
                           New_Reference_To (RTE (RE_Base_Pool), Loc),
                         Parameter_Associations => New_List (
                           Make_Explicit_Dereference (Loc,
-                            Prefix => New_Reference_To (Collect, Loc)))))));
+                            Prefix => New_Reference_To (Fin_Mas_Id, Loc)))))));
 
             --  Create an access type which uses the storage pool of the
-            --  caller's collection.
+            --  caller's finalization master.
 
             --  Generate:
             --    type Ptr_Typ is access Obj_Typ;
@@ -2167,11 +2164,11 @@
                   Make_Access_To_Object_Definition (Loc,
                     Subtype_Indication => New_Reference_To (Obj_Typ, Loc))));
 
-            --  Perform minor decoration in order to set the collection and the
+            --  Perform minor decoration in order to set the master and the
             --  storage pool attributes.
 
             Set_Ekind (Ptr_Typ, E_Access_Type);
-            Set_Associated_Collection   (Ptr_Typ, Collect);
+            Set_Finalization_Master     (Ptr_Typ, Fin_Mas_Id);
             Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
 
             --  Create an explicit free statement. Note that the free uses the
@@ -2203,18 +2200,18 @@
                     Statements => New_List (Free_Stmt)));
 
             --  Generate:
-            --    if BIPcollection /= null then
+            --    if BIPfinalizationmaster /= null then
 
             Cond :=
               Make_Op_Ne (Loc,
-                Left_Opnd  => New_Reference_To (Collect, Loc),
+                Left_Opnd  => New_Reference_To (Fin_Mas_Id, Loc),
                 Right_Opnd => Make_Null (Loc));
 
             --  For constrained or tagged results escalate the condition to
             --  include the allocation format. Generate:
             --
             --    if BIPallocform > Secondary_Stack'Pos
-            --      and then BIPcollection /= null
+            --      and then BIPfinalizationmaster /= null
             --    then
 
             if not Is_Constrained (Obj_Typ)
@@ -2590,11 +2587,13 @@
             --  If we are dealing with a return object of a build-in-place
             --  function, generate the following cleanup statements:
             --
-            --    if BIPallocfrom > Secondary_Stack'Pos then
+            --    if BIPallocfrom > Secondary_Stack'Pos
+            --      and then BIPfinalizationmaster /= null
+            --    then
             --       declare
             --          type Ptr_Typ is access Obj_Typ;
             --          for Ptr_Typ'Storage_Pool use
-            --                Base_Pool (BIPcollection.all).all;
+            --                Base_Pool (BIPfinalizationmaster.all).all;
             --
             --       begin
             --          Free (Ptr_Typ (Temp));
@@ -2602,17 +2601,15 @@
             --    end if;
             --
             --  The generated code effectively detaches the temporary from the
-            --  caller finalization chain and deallocates the object. This is
+            --  caller finalization master and deallocates the object. This is
             --  disabled on .NET/JVM because pools are not supported.
 
-            --  H505-021 This needs to be revisited on .NET/JVM
-
             if VM_Target = No_VM and then Is_Return_Object (Obj_Id) then
                declare
                   Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
                begin
                   if Is_Build_In_Place_Function (Func_Id)
-                    and then Needs_BIP_Collection (Func_Id)
+                    and then Needs_BIP_Finalization_Master (Func_Id)
                   then
                      Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
                   end if;
@@ -4632,7 +4629,7 @@
           Name                   =>
             New_Reference_To (RTE (RE_Attach), Loc),
           Parameter_Associations => New_List (
-            New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
+            New_Reference_To (Finalization_Master (Ptr_Typ), Loc),
             Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
    end Make_Attach_Call;
 
@@ -6849,17 +6846,16 @@
             Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
          end if;
 
-      --  For types that are both controlled and have controlled components,
-      --  generate a call to Deep_Finalize.
+      --  Derivations from [Limited_]Controlled
 
-      elsif Is_Controlled (Utyp)
-        and then Has_Controlled_Component (Utyp)
-      then
-         Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
+      elsif Is_Controlled (Utyp) then
+         if Has_Controlled_Component (Utyp) then
+            Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
+         else
+            Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
+         end if;
 
-      --  For types that are not controlled themselves, but contain controlled
-      --  components or can be extended by types with controlled components,
-      --  create a call to Deep_Finalize.
+      --  Class-wide types, interfaces and types with controlled components
 
       elsif Is_Class_Wide_Type (Typ)
         or else Is_Interface (Typ)
@@ -6871,11 +6867,13 @@
             Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
          end if;
 
-      --  For types that are derived from Controlled and do not have controlled
-      --  components, build a call to Finalize.
+      --  Tagged types
 
+      elsif Is_Tagged_Type (Utyp) then
+         Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
+
       else
-         Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
+         raise Program_Error;
       end if;
 
       if Present (Fin_Id) then
@@ -6927,6 +6925,9 @@
    --------------------------------
 
    procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
+      Loc     : constant Source_Ptr := Sloc (Typ);
+      Proc_Id : Entity_Id;
+
    begin
       --  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
@@ -6934,6 +6935,7 @@
       --  do not need the Finalize_Address primitive.
 
       if not Needs_Finalization (Typ)
+        or else Is_Abstract_Type (Typ)
         or else Present (TSS (Typ, TSS_Finalize_Address))
         or else
           (Is_Class_Wide_Type (Typ)
@@ -6943,48 +6945,42 @@
          return;
       end if;
 
-      declare
-         Loc     : constant Source_Ptr := Sloc (Typ);
-         Proc_Id : Entity_Id;
+      Proc_Id :=
+        Make_Defining_Identifier (Loc,
+          Make_TSS_Name (Typ, TSS_Finalize_Address));
 
-      begin
-         Proc_Id :=
-           Make_Defining_Identifier (Loc,
-             Make_TSS_Name (Typ, TSS_Finalize_Address));
+      --  Generate:
+      --    procedure <Typ>FD (V : System.Address) is
+      --    begin
+      --       declare
+      --          type Pnn is access all Typ;
+      --          for Pnn'Storage_Size use 0;
+      --       begin
+      --          [Deep_]Finalize (Pnn (V).all);
+      --       end;
+      --    end TypFD;
 
-         --  Generate:
-         --    procedure TypFD (V : System.Address) is
-         --    begin
-         --       declare
-         --          type Pnn is access all Typ;
-         --          for Pnn'Storage_Size use 0;
-         --       begin
-         --          [Deep_]Finalize (Pnn (V).all);
-         --       end;
-         --    end TypFD;
+      Discard_Node (
+        Make_Subprogram_Body (Loc,
+          Specification =>
+            Make_Procedure_Specification (Loc,
+              Defining_Unit_Name => Proc_Id,
 
-         Discard_Node (
-           Make_Subprogram_Body (Loc,
-             Specification =>
-               Make_Procedure_Specification (Loc,
-                 Defining_Unit_Name => Proc_Id,
+              Parameter_Specifications => New_List (
+                Make_Parameter_Specification (Loc,
+                  Defining_Identifier =>
+                    Make_Defining_Identifier (Loc, Name_V),
+                  Parameter_Type =>
+                    New_Reference_To (RTE (RE_Address), Loc)))),
 
-                 Parameter_Specifications => New_List (
-                   Make_Parameter_Specification (Loc,
-                     Defining_Identifier =>
-                       Make_Defining_Identifier (Loc, Name_V),
-                     Parameter_Type =>
-                       New_Reference_To (RTE (RE_Address), Loc)))),
+          Declarations => No_List,
 
-             Declarations => No_List,
+          Handled_Statement_Sequence =>
+            Make_Handled_Sequence_Of_Statements (Loc,
+              Statements =>
+                Make_Finalize_Address_Stmts (Typ))));
 
-             Handled_Statement_Sequence =>
-               Make_Handled_Sequence_Of_Statements (Loc,
-                 Statements =>
-                   Make_Finalize_Address_Stmts (Typ))));
-
-         Set_TSS (Typ, Proc_Id);
-      end;
+      Set_TSS (Typ, Proc_Id);
    end Make_Finalize_Address_Body;
 
    ---------------------------------
@@ -7415,86 +7411,6 @@
               Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
    end Make_Local_Deep_Finalize;
 
-   ----------------------------------------
-   -- Make_Set_Finalize_Address_Ptr_Call --
-   ----------------------------------------
-
-   function Make_Set_Finalize_Address_Ptr_Call
-     (Loc     : Source_Ptr;
-      Typ     : Entity_Id;
-      Ptr_Typ : Entity_Id) return Node_Id
-   is
-      Desig_Typ : constant Entity_Id :=
-                    Available_View (Designated_Type (Ptr_Typ));
-      Utyp      : Entity_Id;
-
-   begin
-      --  If the context is a class-wide allocator, we use the class-wide type
-      --  to obtain the proper Finalize_Address routine.
-
-      if Is_Class_Wide_Type (Desig_Typ) then
-         Utyp := Desig_Typ;
-
-      else
-         Utyp := Typ;
-
-         if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
-            Utyp := Full_View (Utyp);
-         end if;
-
-         if Is_Concurrent_Type (Utyp) then
-            Utyp := Corresponding_Record_Type (Utyp);
-         end if;
-      end if;
-
-      Utyp := Underlying_Type (Base_Type (Utyp));
-
-      --  Deal with non-tagged derivation of private views. If the parent is
-      --  now known to be protected, the finalization routine is the one
-      --  defined on the corresponding record of the ancestor (corresponding
-      --  records do not automatically inherit operations, but maybe they
-      --  should???)
-
-      if Is_Untagged_Derivation (Typ) then
-         if Is_Protected_Type (Typ) then
-            Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
-         else
-            Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
-
-            if Is_Protected_Type (Utyp) then
-               Utyp := Corresponding_Record_Type (Utyp);
-            end if;
-         end if;
-      end if;
-
-      --  If the underlying_type is a subtype, we are dealing with the
-      --  completion of a private type. We need to access the base type and
-      --  generate a conversion to it.
-
-      if Utyp /= Base_Type (Utyp) then
-         pragma Assert (Is_Private_Type (Typ));
-
-         Utyp := Base_Type (Utyp);
-      end if;
-
-      --  Generate:
-      --    Set_Finalize_Address_Ptr
-      --      (<Ptr_Typ>FC, <Utyp>FD'Unrestricted_Access);
-
-      return
-        Make_Procedure_Call_Statement (Loc,
-          Name                   =>
-            New_Reference_To (RTE (RE_Set_Finalize_Address_Ptr), Loc),
-
-          Parameter_Associations => New_List (
-            New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
-
-            Make_Attribute_Reference (Loc,
-              Prefix         =>
-                New_Reference_To (TSS (Utyp, TSS_Finalize_Address), Loc),
-              Attribute_Name => Name_Unrestricted_Access)));
-   end Make_Set_Finalize_Address_Ptr_Call;
-
    --------------------------
    -- Make_Transient_Block --
    --------------------------
Index: exp_ch7.ads
===================================================================
--- exp_ch7.ads	(revision 178155)
+++ exp_ch7.ads	(working copy)
@@ -40,15 +40,15 @@
    --  Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize
    --  that take care of finalization management at run-time.
 
-   procedure Build_Finalization_Collection
+   procedure Build_Finalization_Master
      (Typ        : Entity_Id;
       Ins_Node   : Node_Id := Empty;
       Encl_Scope : Entity_Id := Empty);
-   --  Build a finalization collection for an access type. The designated type
-   --  may not necessarely be controlled or need finalization actions. The
-   --  routine creates a wrapper around a user-defined storage pool or the
-   --  general storage pool for access types. Ins_Nod and Encl_Scope are used
-   --  in conjunction with anonymous access types. Ins_Node designates the
+   --  Build a finalization master for an access type. The designated type may
+   --  not necessarely be controlled or need finalization actions. The routine
+   --  creates a wrapper around a user-defined storage pool or the general
+   --  storage pool for access types. Ins_Nod and Encl_Scope are used in
+   --  conjunction with anonymous access types. Ins_Node designates the
    --  insertion point before which the collection should be added. Encl_Scope
    --  is the scope of the context, either the enclosing record or the scope
    --  of the related function.
@@ -173,18 +173,6 @@
    --  Create a special version of Deep_Finalize with identifier Nam. The
    --  routine has state information and can parform partial finalization.
 
-   function Make_Set_Finalize_Address_Ptr_Call
-     (Loc     : Source_Ptr;
-      Typ     : Entity_Id;
-      Ptr_Typ : Entity_Id) return Node_Id;
-   --  Generate the following call:
-   --
-   --    Set_Finalize_Address_Ptr (<Ptr_Typ>FC, <Typ>FD'Unrestricted_Access);
-   --
-   --  where Finalize_Address is the corresponding TSS primitive of type Typ
-   --  and Ptr_Typ is the access type of the related allocation. Loc is the
-   --  source location of the related allocator.
-
    --------------------------------------------
    -- Task and Protected Object finalization --
    --------------------------------------------
Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 178182)
+++ exp_util.adb	(working copy)
@@ -332,6 +332,9 @@
       Desig_Typ : constant Entity_Id :=
                     Available_View (Designated_Type (Ptr_Typ));
 
+      function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id;
+      --  Locate TSS primitive Finalize_Address in type Typ
+
       function Find_Object (E : Node_Id) return Node_Id;
       --  Given an arbitrary expression of an allocator, try to find an object
       --  reference in it, otherwise return the original expression.
@@ -340,6 +343,57 @@
       --  Determine whether subprogram Subp denotes a custom allocate or
       --  deallocate.
 
+      ---------------------------
+      -- Find_Finalize_Address --
+      ---------------------------
+
+      function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id is
+         Utyp : Entity_Id := Typ;
+
+      begin
+         if Is_Private_Type (Utyp)
+           and then Present (Full_View (Utyp))
+         then
+            Utyp := Full_View (Utyp);
+         end if;
+
+         if Is_Concurrent_Type (Utyp) then
+            Utyp := Corresponding_Record_Type (Utyp);
+         end if;
+
+         Utyp := Underlying_Type (Base_Type (Utyp));
+
+         --  Deal with non-tagged derivation of private views. If the parent is
+         --  now known to be protected, the finalization routine is the one
+         --  defined on the corresponding record of the ancestor (corresponding
+         --  records do not automatically inherit operations, but maybe they
+         --  should???)
+
+         if Is_Untagged_Derivation (Typ) then
+            if Is_Protected_Type (Typ) then
+               Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
+            else
+               Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
+
+               if Is_Protected_Type (Utyp) then
+                  Utyp := Corresponding_Record_Type (Utyp);
+               end if;
+            end if;
+         end if;
+
+         --  If the underlying_type is a subtype, we are dealing with the
+         --  completion of a private type. We need to access the base type and
+         --  generate a conversion to it.
+
+         if Utyp /= Base_Type (Utyp) then
+            pragma Assert (Is_Private_Type (Typ));
+
+            Utyp := Base_Type (Utyp);
+         end if;
+
+         return TSS (Utyp, TSS_Finalize_Address);
+      end Find_Finalize_Address;
+
       -----------------
       -- Find_Object --
       -----------------
@@ -375,8 +429,7 @@
       function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
       begin
          --  Look for a subprogram body with only one statement which is a
-         --  call to one of the Allocate / Deallocate routines in package
-         --  Ada.Finalization.Heap_Management.
+         --  call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
 
          if Ekind (Subp) = E_Procedure
            and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
@@ -394,8 +447,8 @@
                   Proc := Entity (Name (First (Statements (HSS))));
 
                   return
-                    Is_RTE (Proc, RE_Allocate)
-                      or else Is_RTE (Proc, RE_Deallocate);
+                    Is_RTE (Proc, RE_Allocate_Any_Controlled)
+                      or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
                end if;
             end;
          end if;
@@ -430,137 +483,191 @@
          Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
 
          Actuals      : List_Id;
-         Collect_Act  : Node_Id;
-         Collect_Id   : Entity_Id;
-         Collect_Typ  : Entity_Id;
+         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;
 
       begin
-         --  When dealing with an access subtype, use the collection of the
-         --  base type.
+         --  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
-            Collect_Typ := Base_Type (Ptr_Typ);
+            Fin_Mas_Typ := Base_Type (Ptr_Typ);
          else
-            Collect_Typ := Ptr_Typ;
+            Fin_Mas_Typ := Ptr_Typ;
          end if;
 
-         Collect_Id  := Associated_Collection (Collect_Typ);
-         Collect_Act := New_Reference_To (Collect_Id, Loc);
+         Actuals := New_List;
 
-         --  Handle the case where the collection is actually a pointer to a
-         --  collection. This case arises in build-in-place functions.
+         --  Step 1: Construct all the actuals for the call to library routine
+         --  Allocate_Any_Controlled / Deallocate_Any_Controlled.
 
-         if Is_Access_Type (Etype (Collect_Id)) then
-            Collect_Act :=
-              Make_Explicit_Dereference (Loc,
-                Prefix => Collect_Act);
-         end if;
+         --  a) Storage pool
 
-         --  Create the actuals for the call to Allocate / Deallocate
+         Append_To (Actuals,
+           New_Reference_To (Associated_Storage_Pool (Fin_Mas_Typ), Loc));
 
-         Actuals := New_List (
-           Collect_Act,
-           New_Reference_To (Addr_Id, Loc),
-           New_Reference_To (Size_Id, Loc),
-           New_Reference_To (Alig_Id, Loc));
+         if Is_Allocate then
 
-         --  Generate a run-time check to determine whether a class-wide object
-         --  is truly controlled.
+            --  b) Subpool
 
-         if Is_Class_Wide_Type (Desig_Typ)
-           or else Is_Generic_Actual_Type (Desig_Typ)
-         then
-            declare
-               Flag_Id   : constant Entity_Id := Make_Temporary (Loc, 'F');
-               Flag_Expr : Node_Id;
-               Param     : Node_Id;
-               Temp      : Node_Id;
+            if Present (Subpool_Handle_Name (Expr)) then
+               Append_To (Actuals,
+                 New_Reference_To (Entity (Subpool_Handle_Name (Expr)), Loc));
+            else
+               Append_To (Actuals, Make_Null (Loc));
+            end if;
 
-            begin
-               if Is_Allocate then
-                  Temp := Find_Object (Expression (Expr));
+            --  c) Finalization master
+
+            if Needs_Finalization (Desig_Typ) then
+               Fin_Mas_Id  := Finalization_Master (Fin_Mas_Typ);
+               Fin_Mas_Act := New_Reference_To (Fin_Mas_Id, Loc);
+
+               --  Handle the case where the master is actually a pointer to a
+               --  master. This case arises in build-in-place functions.
+
+               if Is_Access_Type (Etype (Fin_Mas_Id)) then
+                  Append_To (Actuals, Fin_Mas_Act);
                else
-                  Temp := Expr;
+                  Append_To (Actuals,
+                    Make_Attribute_Reference (Loc,
+                      Prefix         => Fin_Mas_Act,
+                      Attribute_Name => Name_Unrestricted_Access));
                end if;
+            else
+               Append_To (Actuals, Make_Null (Loc));
+            end if;
 
-               --  Processing for generic actuals
+            --  d) Finalize_Address
 
-               if Is_Generic_Actual_Type (Desig_Typ) then
-                  Flag_Expr :=
-                    New_Reference_To (Boolean_Literals
-                      (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
+            Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
 
-               --  Processing for subtype indications
+            if Present (Fin_Addr_Id) then
+               Append_To (Actuals,
+                 Make_Attribute_Reference (Loc,
+                   Prefix         => New_Reference_To (Fin_Addr_Id, Loc),
+                   Attribute_Name => Name_Unrestricted_Access));
+            else
+               Append_To (Actuals, Make_Null (Loc));
+            end if;
+         end if;
 
-               elsif Nkind (Temp) in N_Has_Entity
-                 and then Is_Type (Entity (Temp))
-               then
-                  Flag_Expr :=
-                    New_Reference_To (Boolean_Literals
-                      (Needs_Finalization (Entity (Temp))), Loc);
+         --  e) Address
+         --  f) Storage_Size
+         --  g) Alignment
 
-               --  Generate a runtime check to test the controlled state of an
-               --  object for the purposes of allocation / deallocation.
+         Append_To (Actuals, New_Reference_To (Addr_Id, Loc));
+         Append_To (Actuals, New_Reference_To (Size_Id, Loc));
+         Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
 
-               else
-                  --  The following case arises when allocating through an
-                  --  interface class-wide type, generate:
-                  --
-                  --    Temp.all
+         --  h) Is_Controlled
 
-                  if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
-                     Param :=
-                       Make_Explicit_Dereference (Loc,
-                         Prefix =>
-                           Relocate_Node (Temp));
+         --  Generate a run-time check to determine whether a class-wide object
+         --  is truly controlled.
 
-                  --  Generate:
-                  --    Temp'Tag
+         if Needs_Finalization (Desig_Typ) then
+            if Is_Class_Wide_Type (Desig_Typ)
+              or else Is_Generic_Actual_Type (Desig_Typ)
+            then
+               declare
+                  Flag_Id   : constant Entity_Id := Make_Temporary (Loc, 'F');
+                  Flag_Expr : Node_Id;
+                  Param     : Node_Id;
+                  Temp      : Node_Id;
 
+               begin
+                  if Is_Allocate then
+                     Temp := Find_Object (Expression (Expr));
                   else
-                     Param :=
-                       Make_Attribute_Reference (Loc,
-                         Prefix =>
-                           Relocate_Node (Temp),
-                         Attribute_Name => Name_Tag);
+                     Temp := Expr;
                   end if;
 
-                  --  Generate:
-                  --    Needs_Finalization (Param)
+                  --  Processing for generic actuals
 
-                  Flag_Expr :=
-                    Make_Function_Call (Loc,
-                      Name =>
-                        New_Reference_To (RTE (RE_Needs_Finalization), Loc),
-                      Parameter_Associations => New_List (Param));
-               end if;
+                  if Is_Generic_Actual_Type (Desig_Typ) then
+                     Flag_Expr :=
+                       New_Reference_To (Boolean_Literals
+                         (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
 
-               --  Create the temporary which represents the finalization state
-               --  of the expression. Generate:
-               --
-               --    F : constant Boolean := <Flag_Expr>;
+                  --  Processing for subtype indications
 
-               Insert_Action (N,
-                 Make_Object_Declaration (Loc,
-                   Defining_Identifier => Flag_Id,
-                   Constant_Present => True,
-                   Object_Definition =>
-                     New_Reference_To (Standard_Boolean, Loc),
-                   Expression => Flag_Expr));
+                  elsif Nkind (Temp) in N_Has_Entity
+                    and then Is_Type (Entity (Temp))
+                  then
+                     Flag_Expr :=
+                       New_Reference_To (Boolean_Literals
+                         (Needs_Finalization (Entity (Temp))), Loc);
 
-               --  The flag acts as the fifth actual
+                  --  Generate a runtime check to test the controlled state of
+                  --  an object for the purposes of allocation / deallocation.
 
-               Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
-            end;
+                  else
+                     --  The following case arises when allocating through an
+                     --  interface class-wide type, generate:
+                     --
+                     --    Temp.all
+
+                     if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
+                        Param :=
+                          Make_Explicit_Dereference (Loc,
+                            Prefix =>
+                              Relocate_Node (Temp));
+
+                     --  Generate:
+                     --    Temp'Tag
+
+                     else
+                        Param :=
+                          Make_Attribute_Reference (Loc,
+                            Prefix =>
+                              Relocate_Node (Temp),
+                            Attribute_Name => Name_Tag);
+                     end if;
+
+                     --  Generate:
+                     --    Needs_Finalization (<Param>)
+
+                     Flag_Expr :=
+                       Make_Function_Call (Loc,
+                         Name =>
+                           New_Reference_To (RTE (RE_Needs_Finalization), Loc),
+                         Parameter_Associations => New_List (Param));
+                  end if;
+
+                  --  Create the temporary which represents the finalization
+                  --  state of the expression. Generate:
+                  --
+                  --    F : constant Boolean := <Flag_Expr>;
+
+                  Insert_Action (N,
+                    Make_Object_Declaration (Loc,
+                      Defining_Identifier => Flag_Id,
+                      Constant_Present => True,
+                      Object_Definition =>
+                        New_Reference_To (Standard_Boolean, Loc),
+                      Expression => Flag_Expr));
+
+                  --  The flag acts as the last actual
+
+                  Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
+               end;
+            end if;
+         else
+            Append_To (Actuals, New_Reference_To (Standard_False, Loc));
          end if;
 
+         --  Step 2: Build a wrapper Allocate / Deallocate which internally
+         --  calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
+
          --  Select the proper routine to call
 
          if Is_Allocate then
-            Proc_To_Call := RTE (RE_Allocate);
+            Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
          else
-            Proc_To_Call := RTE (RE_Deallocate);
+            Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
          end if;
 
          --  Create a custom Allocate / Deallocate routine which has identical
@@ -611,10 +718,6 @@
              Handled_Statement_Sequence =>
                Make_Handled_Sequence_Of_Statements (Loc,
                  Statements => New_List (
-
-                  --  Allocate / Deallocate
-                  --    (<Ptr_Typ collection>, A, S, L[, F]);
-
                    Make_Procedure_Call_Statement (Loc,
                      Name =>
                        New_Reference_To (Proc_To_Call, Loc),
@@ -3752,7 +3855,7 @@
           and then Nkind (Rel_Node) /= N_Simple_Return_Statement
 
          --  Do not consider transient objects allocated on the heap since they
-         --  are attached to a finalization collection.
+         --  are attached to a finalization master.
 
           and then not Is_Allocated (Obj_Id)
 
@@ -6431,16 +6534,16 @@
                return True;
             end if;
 
-         --  Inspect the freeze node of an access-to-controlled type and
-         --  look for a delayed finalization collection. This case arises
-         --  when the freeze actions are inserted at a later time than the
-         --  expansion of the context. Since Build_Finalizer is never called
-         --  on a single construct twice, the collection will be ultimately
-         --  left out and never finalized. This is also needed for freeze
-         --  actions of designated types themselves, since in some cases the
-         --  finalization collection is associated with a designated type's
-         --  freeze node rather than that of the access type (see handling
-         --  for freeze actions in Build_Finalization_Collection).
+         --  Inspect the freeze node of an access-to-controlled type and look
+         --  for a delayed finalization master. This case arises when the
+         --  freeze actions are inserted at a later time than the expansion of
+         --  the context. Since Build_Finalizer is never called on a single
+         --  construct twice, the master will be ultimately left out and never
+         --  finalized. This is also needed for freeze actions of designated
+         --  types themselves, since in some cases the finalization master is
+         --  associated with a designated type's freeze node rather than that
+         --  of the access type (see handling for freeze actions in
+         --  Build_Finalization_Master).
 
          elsif Nkind (Decl) = N_Freeze_Entity
            and then Present (Actions (Decl))
@@ -6451,9 +6554,9 @@
                   and then not Is_Access_Subprogram_Type (Typ)
                   and then Needs_Finalization
                              (Available_View (Designated_Type (Typ))))
-                 or else
-                   (Is_Type (Typ)
-                     and then Needs_Finalization (Typ)))
+               or else
+                (Is_Type (Typ)
+                   and then Needs_Finalization (Typ)))
               and then Requires_Cleanup_Actions
                          (Actions (Decl), For_Package, Nested_Constructs)
             then
Index: exp_util.ads
===================================================================
--- exp_util.ads	(revision 178155)
+++ exp_util.ads	(working copy)
@@ -202,21 +202,7 @@
    --  allocation, N is the declaration of the 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. The generated routine is:
-   --
-   --     F : constant Boolean :=                          --  CW case
-   --           Ada.Tags.Needs_Finalization (<Expr>'Tag);  --  CW case
-   --
-   --     procedure Allocate / Deallocate
-   --       (P : Storage_Pool;
-   --        A : [out] Address;  --  out is present for Allocate
-   --        S : Storage_Count;
-   --        L : Storage_Count)
-   --     is
-   --     begin
-   --        Allocate / Deallocate
-   --          (<Ptr_Typ collection>, A, S, L, [Needs_Header => F]);
-   --     end Allocate;
+   --  routine is allocate, deallocate otherwise.
 
    function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id;
    --  Build an N_Procedure_Call_Statement calling the given runtime entity.
Index: einfo.adb
===================================================================
--- einfo.adb	(revision 178156)
+++ einfo.adb	(working copy)
@@ -195,11 +195,11 @@
    --    Scope_Depth_Value               Uint22
    --    Shared_Var_Procs_Instance       Node22
 
-   --    Associated_Collection           Node23
    --    CR_Discriminant                 Node23
    --    Entry_Cancel_Parameter          Node23
    --    Enum_Pos_To_Rep                 Node23
    --    Extra_Constrained               Node23
+   --    Finalization_Master             Node23
    --    Generic_Renamings               Elist23
    --    Inner_Instances                 Elist23
    --    Limited_View                    Node23
@@ -612,12 +612,6 @@
       return Uint14 (Id);
    end Alignment;
 
-   function Associated_Collection (Id : E) return E is
-   begin
-      pragma Assert (Is_Access_Type (Id));
-      return Node23 (Id);
-   end Associated_Collection;
-
    function Associated_Formal_Package (Id : E) return E is
    begin
       pragma Assert (Ekind (Id) = E_Package);
@@ -1075,6 +1069,12 @@
       return Flag229 (Base_Type (Id));
    end Can_Use_Internal_Rep;
 
+   function Finalization_Master (Id : E) return E is
+   begin
+      pragma Assert (Is_Access_Type (Id));
+      return Node23 (Root_Type (Id));
+   end Finalization_Master;
+
    function Finalize_Storage_Only (Id : E) return B is
    begin
       pragma Assert (Is_Type (Id));
@@ -3051,12 +3051,6 @@
       Set_Elist16 (Id, V);
    end Set_Access_Disp_Table;
 
-   procedure Set_Associated_Collection (Id : E; V : E) is
-   begin
-      pragma Assert (Is_Access_Type (Id));
-      Set_Node23 (Id, V);
-   end Set_Associated_Collection;
-
    procedure Set_Associated_Formal_Package (Id : E; V : E) is
    begin
       Set_Node12 (Id, V);
@@ -3544,6 +3538,12 @@
       Set_Flag229 (Id, V);
    end Set_Can_Use_Internal_Rep;
 
+   procedure Set_Finalization_Master (Id : E; V : E) is
+   begin
+      pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
+      Set_Node23 (Id, V);
+   end Set_Finalization_Master;
+
    procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is
    begin
       pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
@@ -6941,16 +6941,8 @@
       if Ekind (T) = E_Class_Wide_Type then
          return Etype (T);
 
-      elsif Ekind (T) = E_Class_Wide_Subtype then
-         return Etype (Base_Type (T));
+      --  Other cases
 
-         --  ??? T comes from Base_Type, how can it be a subtype?
-         --  Also Base_Type is supposed to be idempotent, so either way
-         --  this is equivalent to "return Etype (T)" and should be merged
-         --  with the E_Class_Wide_Type case.
-
-      --  All other cases
-
       else
          loop
             Etyp := Etype (T);
@@ -8459,9 +8451,6 @@
    procedure Write_Field23_Name (Id : Entity_Id) is
    begin
       case Ekind (Id) is
-         when Access_Kind                                  =>
-            Write_Str ("Associated_Collection");
-
          when E_Discriminant                               =>
             Write_Str ("CR_Discriminant");
 
@@ -8475,6 +8464,9 @@
               E_Variable                                   =>
             Write_Str ("Extra_Constrained");
 
+         when Access_Kind                                  =>
+            Write_Str ("Finalization_Master");
+
          when E_Generic_Function                           |
               E_Generic_Package                            |
               E_Generic_Procedure                          =>
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 178182)
+++ einfo.ads	(working copy)
@@ -427,12 +427,6 @@
 --       definition clause with an (obsolescent) mod clause is converted
 --       into an attribute definition clause for this purpose.
 
---    Associated_Collection (Node23)
---       Present in non-subprogram access type entities. Contains the entity of
---       the finalization collection on which dynamically allocated objects
---       referenced by the access type are stored. Empty when the access type
---       cannot reference a controlled object.
-
 --    Associated_Formal_Package (Node12)
 --       Present in packages that are the actuals of formal_packages. Points
 --       to the entity in the declaration for the formal package.
@@ -1144,6 +1138,13 @@
 --       must be retrieved through the entity designed by this field instead of
 --       being computed.
 
+--    Finalization_Master (Node23) [root type only]
+--       Present in access-to-controlled or access-to-class-wide types. The
+--       field contains the entity of the finalization master which handles
+--       dynamically allocated controlled objects referenced by the access
+--       type. Empty for access-to-subprogram types. Empty for access types
+--       whose designated type does not need finalization actions.
+
 --    Finalize_Storage_Only (Flag158) [base type only]
 --       Present in all types. Set on direct controlled types to which a
 --       valid Finalize_Storage_Only pragma applies. This flag is also set on
@@ -4943,7 +4944,7 @@
    --    Master_Id                           (Node17)
    --    Directly_Designated_Type            (Node20)
    --    Associated_Storage_Pool             (Node22)   (base type only)
-   --    Associated_Collection               (Node23)   (base type only)
+   --    Finalization_Master                 (Node23)   (base type only)
    --    Has_Pragma_Controlled               (Flag27)   (base type only)
    --    Has_Storage_Size_Clause             (Flag23)   (base type only)
    --    Is_Access_Constant                  (Flag69)
@@ -4971,7 +4972,7 @@
    --  E_Anonymous_Access_Type
    --    Storage_Size_Variable               (Node15)   ??? is this needed ???
    --    Directly_Designated_Type            (Node20)
-   --    Associated_Collection               (Node23)
+   --    Finalization_Master                 (Node23)
    --    (plus type attributes)
 
    --  E_Array_Type
@@ -5278,7 +5279,7 @@
    --    Master_Id                           (Node17)
    --    Directly_Designated_Type            (Node20)
    --    Associated_Storage_Pool             (Node22)   (root type only)
-   --    Associated_Collection               (Node23)
+   --    Finalization_Master                 (Node23)   (root type only)
    --    (plus type attributes)
 
    --  E_Generic_In_Parameter
@@ -5974,7 +5975,6 @@
    function Address_Taken                       (Id : E) return B;
    function Alias                               (Id : E) return E;
    function Alignment                           (Id : E) return U;
-   function Associated_Collection               (Id : E) return E;
    function Associated_Formal_Package           (Id : E) return E;
    function Associated_Node_For_Itype           (Id : E) return N;
    function Associated_Storage_Pool             (Id : E) return E;
@@ -6050,6 +6050,7 @@
    function Extra_Formal                        (Id : E) return E;
    function Extra_Formals                       (Id : E) return E;
    function Can_Use_Internal_Rep                (Id : E) return B;
+   function Finalization_Master                 (Id : E) return E;
    function Finalize_Storage_Only               (Id : E) return B;
    function Finalizer                           (Id : E) return E;
    function First_Entity                        (Id : E) return E;
@@ -6563,7 +6564,6 @@
    procedure Set_Address_Taken                   (Id : E; V : B := True);
    procedure Set_Alias                           (Id : E; V : E);
    procedure Set_Alignment                       (Id : E; V : U);
-   procedure Set_Associated_Collection           (Id : E; V : E);
    procedure Set_Associated_Formal_Package       (Id : E; V : E);
    procedure Set_Associated_Node_For_Itype       (Id : E; V : N);
    procedure Set_Associated_Storage_Pool         (Id : E; V : E);
@@ -6637,6 +6637,7 @@
    procedure Set_Extra_Formal                    (Id : E; V : E);
    procedure Set_Extra_Formals                   (Id : E; V : E);
    procedure Set_Can_Use_Internal_Rep            (Id : E; V : B := True);
+   procedure Set_Finalization_Master             (Id : E; V : E);
    procedure Set_Finalize_Storage_Only           (Id : E; V : B := True);
    procedure Set_Finalizer                       (Id : E; V : E);
    procedure Set_First_Entity                    (Id : E; V : E);
@@ -7259,7 +7260,6 @@
    pragma Inline (Address_Taken);
    pragma Inline (Alias);
    pragma Inline (Alignment);
-   pragma Inline (Associated_Collection);
    pragma Inline (Associated_Formal_Package);
    pragma Inline (Associated_Node_For_Itype);
    pragma Inline (Associated_Storage_Pool);
@@ -7335,6 +7335,7 @@
    pragma Inline (Extra_Formal);
    pragma Inline (Extra_Formals);
    pragma Inline (Can_Use_Internal_Rep);
+   pragma Inline (Finalization_Master);
    pragma Inline (Finalizer);
    pragma Inline (First_Entity);
    pragma Inline (First_Exit_Statement);
@@ -7703,7 +7704,6 @@
    pragma Inline (Set_Address_Taken);
    pragma Inline (Set_Alias);
    pragma Inline (Set_Alignment);
-   pragma Inline (Set_Associated_Collection);
    pragma Inline (Set_Associated_Formal_Package);
    pragma Inline (Set_Associated_Node_For_Itype);
    pragma Inline (Set_Associated_Storage_Pool);
@@ -7778,6 +7778,7 @@
    pragma Inline (Set_Extra_Formal);
    pragma Inline (Set_Extra_Formals);
    pragma Inline (Set_Can_Use_Internal_Rep);
+   pragma Inline (Set_Finalization_Master);
    pragma Inline (Set_Finalizer);
    pragma Inline (Set_First_Entity);
    pragma Inline (Set_First_Exit_Statement);
Index: rtsfind.adb
===================================================================
--- rtsfind.adb	(revision 178155)
+++ rtsfind.adb	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-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- --
@@ -293,9 +293,6 @@
          elsif U_Id in Ada_Dispatching_Child then
             Name_Buffer (16) := '.';
 
-         elsif U_Id in Ada_Finalization_Child then
-            Name_Buffer (17) := '.';
-
          elsif U_Id in Ada_Interrupts_Child then
             Name_Buffer (15) := '.';
 
@@ -324,6 +321,10 @@
       elsif U_Id in System_Child then
          Name_Buffer (7) := '.';
 
+         if U_Id in System_Storage_Pools_Child then
+            Name_Buffer (21) := '.';
+         end if;
+
          if U_Id in System_Strings_Child then
             Name_Buffer (15) := '.';
          end if;
Index: rtsfind.ads
===================================================================
--- rtsfind.ads	(revision 178176)
+++ rtsfind.ads	(working copy)
@@ -48,9 +48,6 @@
    --    eventually, packages implementing delays will be found relative to
    --    the package that declares the time type.
 
-   --    Names of the form Ada_Finalization_xxx are second level children of
-   --    Ada.Finalization.
-
    --    Names of the form Ada_Interrupts_xxx are second level children of
    --    Ada.Interrupts. This is needed for Ada.Interrupts.Names which is used
    --    by pragma Interrupt_State.
@@ -80,6 +77,9 @@
    --    name is System.xxx. For example, the name System_Str_Concat refers to
    --    package System.Str_Concat.
 
+   --    Names of the form System_Storage_Pools_xxx are second level children
+   --    of the package System.Storage_Pools.
+
    --    Names of the form System_Strings_xxx are second level children of the
    --    package System.Strings.
 
@@ -140,10 +140,6 @@
 
       Ada_Dispatching_EDF,
 
-      --  Children of Ada.Finalization
-
-      Ada_Finalization_Heap_Management,
-
       --  Children of Ada.Interrupts
 
       Ada_Interrupts_Names,
@@ -249,6 +245,7 @@
       System_Fat_VAX_D_Float,
       System_Fat_VAX_F_Float,
       System_Fat_VAX_G_Float,
+      System_Finalization_Masters,
       System_Finalization_Root,
       System_Fore,
       System_Img_Bool,
@@ -374,6 +371,10 @@
       System_WWd_Enum,
       System_WWd_Wchar,
 
+      --  Children of System.Storage_Pools
+
+      System_Storage_Pools_Subpools,
+
       --  Children of System.Strings
 
       System_Strings_Stream_Ops,
@@ -403,10 +404,6 @@
      range Ada_Dispatching_EDF .. Ada_Dispatching_EDF;
    --  Range of values for children of Ada.Dispatching
 
-   subtype Ada_Finalization_Child is Ada_Child range
-     Ada_Finalization_Heap_Management .. Ada_Finalization_Heap_Management;
-   --  Range of values for children of Ada.Finalization
-
    subtype Ada_Interrupts_Child is Ada_Child range
      Ada_Interrupts_Names .. Ada_Interrupts_Names;
    --  Range of values for children of Ada.Interrupts
@@ -443,6 +440,9 @@
      range System_Address_Image .. System_Tasking_Stages;
    --  Range of values for children or grandchildren of System
 
+   subtype System_Storage_Pools_Child is RTU_Id
+     range System_Storage_Pools_Subpools .. System_Storage_Pools_Subpools;
+
    subtype System_Strings_Child is RTU_Id
      range System_Strings_Stream_Ops .. System_Strings_Stream_Ops;
 
@@ -521,17 +521,6 @@
      RE_Reraise_Occurrence_No_Defer,     -- Ada.Exceptions
      RE_Save_Occurrence,                 -- Ada.Exceptions
 
-     RE_Add_Offset_To_Address,           -- Ada.Finalization.Heap_Management
-     RE_Allocate,                        -- Ada.Finalization.Heap_Management
-     RE_Attach,                          -- Ada.Finalization.Heap_Management
-     RE_Base_Pool,                       -- Ada.Finalization.Heap_Management
-     RE_Deallocate,                      -- Ada.Finalization.Heap_Management
-     RE_Detach,                          -- Ada.Finalization.Heap_Management
-     RE_Finalization_Collection,         -- Ada.Finalization.Heap_Management
-     RE_Finalization_Collection_Ptr,     -- Ada.Finalization.Heap_Management
-     RE_Set_Finalize_Address_Ptr,        -- Ada.Finalization.Heap_Management
-     RE_Set_Storage_Pool_Ptr,            -- Ada.Finalization.Heap_Management
-
      RE_Interrupt_ID,                    -- Ada.Interrupts
      RE_Is_Reserved,                     -- Ada.Interrupts
      RE_Is_Attached,                     -- Ada.Interrupts
@@ -805,6 +794,14 @@
      RE_Attr_VAX_G_Float,                -- System.Fat_VAX_G_Float
      RE_Fat_VAX_G,                       -- System.Fat_VAX_G_Float
 
+     RE_Add_Offset_To_Address,           -- System.Finalization_Masters
+     RE_Attach,                          -- System.Finalization_Masters
+     RE_Base_Pool,                       -- System.Finalization_Masters
+     RE_Detach,                          -- System.Finalization_Masters
+     RE_Finalization_Master,             -- System.Finalization_Masters
+     RE_Finalization_Master_Ptr,         -- System.Finalization_Masters
+     RE_Set_Base_Pool,                   -- System.Finalization_Masters
+
      RE_Root_Controlled,                 -- System.Finalization_Root
      RE_Root_Controlled_Ptr,             -- System.Finalization_Root
 
@@ -1327,10 +1324,16 @@
      RE_Storage_Offset,                  -- System.Storage_Elements
      RE_To_Address,                      -- System.Storage_Elements
 
+     RE_Allocate_Any,                    -- System.Storage_Pools
+     RE_Deallocate_Any,                  -- System.Storage_Pools
      RE_Root_Storage_Pool,               -- System.Storage_Pools
-     RE_Allocate_Any,                    -- System.Storage_Pools,
-     RE_Deallocate_Any,                  -- System.Storage_Pools,
 
+     RE_Allocate_Any_Controlled,         -- System.Storage_Pools.Subpools
+     RE_Deallocate_Any_Controlled,       -- System.Storage_Pools.Subpools
+     RE_Root_Storage_Pool_With_Subpools, -- System.Storage_Pools.Subpools
+     RE_Root_Subpool,                    -- System.Storage_Pools.Subpools
+     RE_Subpool_Handle,                  -- System.Storage_Pools.Subpools
+
      RE_I_AD,                            -- System.Stream_Attributes
      RE_I_AS,                            -- System.Stream_Attributes
      RE_I_B,                             -- System.Stream_Attributes
@@ -1704,17 +1707,6 @@
      RE_Reraise_Occurrence_No_Defer      => Ada_Exceptions,
      RE_Save_Occurrence                  => Ada_Exceptions,
 
-     RE_Add_Offset_To_Address            => Ada_Finalization_Heap_Management,
-     RE_Allocate                         => Ada_Finalization_Heap_Management,
-     RE_Attach                           => Ada_Finalization_Heap_Management,
-     RE_Base_Pool                        => Ada_Finalization_Heap_Management,
-     RE_Deallocate                       => Ada_Finalization_Heap_Management,
-     RE_Detach                           => Ada_Finalization_Heap_Management,
-     RE_Finalization_Collection          => Ada_Finalization_Heap_Management,
-     RE_Finalization_Collection_Ptr      => Ada_Finalization_Heap_Management,
-     RE_Set_Finalize_Address_Ptr         => Ada_Finalization_Heap_Management,
-     RE_Set_Storage_Pool_Ptr             => Ada_Finalization_Heap_Management,
-
      RE_Interrupt_ID                     => Ada_Interrupts,
      RE_Is_Reserved                      => Ada_Interrupts,
      RE_Is_Attached                      => Ada_Interrupts,
@@ -1988,6 +1980,14 @@
      RE_Attr_VAX_G_Float                 => System_Fat_VAX_G_Float,
      RE_Fat_VAX_G                        => System_Fat_VAX_G_Float,
 
+     RE_Add_Offset_To_Address            => System_Finalization_Masters,
+     RE_Attach                           => System_Finalization_Masters,
+     RE_Base_Pool                        => System_Finalization_Masters,
+     RE_Detach                           => System_Finalization_Masters,
+     RE_Finalization_Master              => System_Finalization_Masters,
+     RE_Finalization_Master_Ptr          => System_Finalization_Masters,
+     RE_Set_Base_Pool                    => System_Finalization_Masters,
+
      RE_Root_Controlled                  => System_Finalization_Root,
      RE_Root_Controlled_Ptr              => System_Finalization_Root,
 
@@ -2510,10 +2510,16 @@
      RE_Storage_Offset                   => System_Storage_Elements,
      RE_To_Address                       => System_Storage_Elements,
 
-     RE_Root_Storage_Pool                => System_Storage_Pools,
      RE_Allocate_Any                     => System_Storage_Pools,
      RE_Deallocate_Any                   => System_Storage_Pools,
+     RE_Root_Storage_Pool                => System_Storage_Pools,
 
+     RE_Allocate_Any_Controlled          => System_Storage_Pools_Subpools,
+     RE_Deallocate_Any_Controlled        => System_Storage_Pools_Subpools,
+     RE_Root_Storage_Pool_With_Subpools  => System_Storage_Pools_Subpools,
+     RE_Root_Subpool                     => System_Storage_Pools_Subpools,
+     RE_Subpool_Handle                   => System_Storage_Pools_Subpools,
+
      RE_I_AD                             => System_Stream_Attributes,
      RE_I_AS                             => System_Stream_Attributes,
      RE_I_B                              => System_Stream_Attributes,
Index: freeze.adb
===================================================================
--- freeze.adb	(revision 178160)
+++ freeze.adb	(working copy)
@@ -1432,27 +1432,27 @@
                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 No (Finalization_Master (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);
@@ -2029,7 +2029,7 @@
             Next_Entity (Comp);
          end loop;
 
-         --  Deal with Bit_Order aspect specifying a non-default bit order
+         --  Deal with pragma Bit_Order setting non-standard bit order
 
          if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then
             if not Placed_Component then
Index: s-stposu.adb
===================================================================
--- s-stposu.adb	(revision 0)
+++ s-stposu.adb	(revision 0)
@@ -0,0 +1,473 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         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         --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--            Copyright (C) 2011, Free Software Foundation, Inc.            --
+--                                                                          --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the  contents of the part following the private keyword. --
+--                                                                          --
+-- 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.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions;              use Ada.Exceptions;
+with Ada.Unchecked_Deallocation;
+
+with System.Finalization_Masters; use System.Finalization_Masters;
+with System.Soft_Links;           use System.Soft_Links;
+with System.Storage_Elements;     use System.Storage_Elements;
+
+package body System.Storage_Pools.Subpools is
+
+   procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr);
+   --  Attach a subpool node to a pool
+
+   procedure Free is new Ada.Unchecked_Deallocation (SP_Node, SP_Node_Ptr);
+
+   procedure Detach (N : not null SP_Node_Ptr);
+   --  Unhook a subpool node from an arbitrary subpool list
+
+   --------------
+   -- Allocate --
+   --------------
+
+   overriding procedure Allocate
+     (Pool                     : in out Root_Storage_Pool_With_Subpools;
+      Storage_Address          : out System.Address;
+      Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
+      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.
+
+      Allocate_From_Subpool
+        (Root_Storage_Pool_With_Subpools'Class (Pool),
+         Storage_Address,
+         Size_In_Storage_Elements,
+         Alignment,
+         Default_Subpool_For_Pool
+           (Root_Storage_Pool_With_Subpools'Class (Pool)));
+   end Allocate;
+
+   -----------------------------
+   -- Allocate_Any_Controlled --
+   -----------------------------
+
+   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;
+      Addr            : out System.Address;
+      Storage_Size    : System.Storage_Elements.Storage_Count;
+      Alignment       : System.Storage_Elements.Storage_Count;
+      Is_Controlled   : Boolean := True)
+   is
+      --  ??? This membership test gives the wrong result when Pool has
+      --  subpools.
+
+      Is_Subpool_Allocation : constant Boolean :=
+                                Pool in Root_Storage_Pool_With_Subpools;
+
+      Master  : Finalization_Master_Ptr := null;
+      N_Addr  : Address;
+      N_Ptr   : FM_Node_Ptr;
+      N_Size  : Storage_Count;
+      Subpool : Subpool_Handle := null;
+
+   begin
+      --  Step 1: Pool-related runtime checks
+
+      --  Allocation on a pool_with_subpools. In this scenario there is a
+      --  master for each subpool.
+
+      if Is_Subpool_Allocation then
+
+         --  Case of an allocation without a Subpool_Handle. Dispatch to the
+         --  implementation of Default_Subpool_For_Pool.
+
+         if Context_Subpool = null then
+            Subpool :=
+              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;
+
+            --  Ensure proper ownership
+
+            if Subpool.Owner /=
+                 Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
+            then
+               raise Program_Error with "incorrect owner of subpool";
+            end if;
+         end if;
+
+         Master := Subpool.Master'Unchecked_Access;
+
+      --  Allocation on a simple pool. In this scenario there is a master for
+      --  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";
+
+         --  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
+            raise Program_Error with "subpool not required in pool allocation";
+         end if;
+
+         Master := Context_Master;
+      end if;
+
+      --  Step 2: Master-related runtime checks
+
+      --  Allocation of a descendant from [Limited_]Controlled, a class-wide
+      --  object or a record with controlled components.
+
+      if Is_Controlled then
+
+         --  Do not allow the allocation of controlled objects while the
+         --  associated master is being finalized.
+
+         if Master.Finalization_Started then
+            raise Program_Error with "allocation after finalization started";
+         end if;
+
+         --  The size must acount for the hidden header preceding the object
+
+         N_Size := Storage_Size + Header_Size;
+
+      --  Non-controlled allocation
+
+      else
+         N_Size := Storage_Size;
+      end if;
+
+      --  Step 3: Allocation of object
+
+      --  For descendants of Root_Storage_Pool_With_Subpools, dispatch to the
+      --  implementation of Allocate_From_Subpool.
+
+      if Is_Subpool_Allocation then
+         Allocate_From_Subpool
+           (Root_Storage_Pool_With_Subpools'Class (Pool),
+            N_Addr, N_Size, Alignment, Subpool);
+
+      --  For descendants of Root_Storage_Pool, dispatch to the implementation
+      --  of Allocate.
+
+      else
+         Allocate (Pool, N_Addr, N_Size, Alignment);
+      end if;
+
+      --  Step 4: Attachment
+
+      if Is_Controlled then
+
+         --  Map the allocated memory into a FM_Node record. This converts the
+         --  top of the allocated bits into a list header.
+
+         N_Ptr := Address_To_FM_Node_Ptr (N_Addr);
+
+         --  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
+
+         Attach (N_Ptr, Master.Objects'Unchecked_Access);
+
+         --  Move the address from the hidden list header to the start of the
+         --  object. This operation effectively hides the list header.
+
+         Addr := N_Addr + Header_Offset;
+      else
+         Addr := N_Addr;
+      end if;
+   end Allocate_Any_Controlled;
+
+   ------------
+   -- Attach --
+   ------------
+
+   procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr) is
+   begin
+      Lock_Task.all;
+
+      L.Next.Prev := N;
+      N.Next := L.Next;
+      L.Next := N;
+      N.Prev := L;
+
+      Unlock_Task.all;
+
+      --  Note: No need to unlock in case of an exception because the above
+      --  code can never raise one.
+   end Attach;
+
+   -------------------------------
+   -- Deallocate_Any_Controlled --
+   -------------------------------
+
+   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
+      N_Addr : Address;
+      N_Ptr  : FM_Node_Ptr;
+      N_Size : Storage_Count;
+
+   begin
+      --  Step 1: Detachment
+
+      if Is_Controlled then
+
+         --  Move the address from the object to the beginning of the list
+         --  header.
+
+         N_Addr := Addr - Header_Offset;
+
+         --  Convert the bits preceding the object into a list header
+
+         N_Ptr := Address_To_FM_Node_Ptr (N_Addr);
+
+         --  Detach the object from the related finalization master. This
+         --  action does not need to know the prior context used during
+         --  allocation.
+
+         Detach (N_Ptr);
+
+         --  The size of the deallocated object must include the size of the
+         --  hidden list header.
+
+         N_Size := Storage_Size + Header_Size;
+      else
+         N_Addr := Addr;
+         N_Size := Storage_Size;
+      end if;
+
+      --  Step 2: Deallocation
+
+      --  Dispatch to the proper implementation of Deallocate. This action
+      --  covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools
+      --  implementations.
+
+      Deallocate (Pool, N_Addr, N_Size, Alignment);
+   end Deallocate_Any_Controlled;
+
+   ------------
+   -- Detach --
+   ------------
+
+   procedure Detach (N : not null SP_Node_Ptr) is
+   begin
+      --  N must be attached to some list
+
+      pragma Assert (N.Next /= null and then N.Prev /= null);
+
+      Lock_Task.all;
+
+      N.Prev.Next := N.Next;
+      N.Next.Prev := N.Prev;
+
+      Unlock_Task.all;
+
+      --  Note: No need to unlock in case of an exception because the above
+      --  code can never raise one.
+   end Detach;
+
+   --------------
+   -- Finalize --
+   --------------
+
+   overriding procedure Finalize
+     (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.
+
+      if Pool.Finalization_Started then
+         return;
+      end if;
+
+      --  Lock the pool to prevent the creation of additional subpools while
+      --  the available ones are finalized. The pool remains locked because
+      --  either it is about to be deallocated or the associated access type
+      --  is about to go out of scope.
+
+      Pool.Finalization_Started := True;
+
+      --  Skip the dummy head
+
+      Curr_Ptr := Pool.Subpools.Next;
+      while Curr_Ptr /= Pool.Subpools'Unchecked_Access loop
+         Next_Ptr := Curr_Ptr.Next;
+
+         --  Remove the subpool node from the subpool list
+
+         Detach (Curr_Ptr);
+
+         --  Finalize the current subpool
+
+         begin
+            Finalize_Subpool (Curr_Ptr.Subpool);
+
+         exception
+            when Fin_Occur : others =>
+               if not Raised then
+                  Raised := True;
+                  Save_Occurrence (Ex_Occur, Fin_Occur);
+               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;
+
+      --  If the finalization of a particular master failed, reraise the
+      --  exception now.
+
+      if Raised then
+         Reraise_Occurrence (Ex_Occur);
+      end if;
+   end Finalize;
+
+   ----------------------
+   -- Finalize_Subpool --
+   ----------------------
+
+   procedure Finalize_Subpool (Subpool : not null Subpool_Handle) is
+   begin
+      Finalize (Subpool.Master);
+   end Finalize_Subpool;
+
+   ---------------------
+   -- Pool_Of_Subpool --
+   ---------------------
+
+   function Pool_Of_Subpool (Subpool : not null Subpool_Handle)
+     return access Root_Storage_Pool_With_Subpools'Class is
+   begin
+      return Subpool.Owner;
+   end Pool_Of_Subpool;
+
+   -------------------------
+   -- Set_Pool_Of_Subpool --
+   -------------------------
+
+   procedure Set_Pool_Of_Subpool
+     (Subpool : not null Subpool_Handle;
+      Pool    : in out Root_Storage_Pool_With_Subpools'Class)
+   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.
+
+      if Subpool.Owner /= null then
+         raise Program_Error with "subpool already belongs to a pool";
+      end if;
+
+      --  Prevent the creation of a new subpool while the owner is being
+      --  finalized. This is a serious error.
+
+      if Pool.Finalization_Started then
+         raise Program_Error
+           with "subpool creation after finalization started";
+      end if;
+
+      --  Create a subpool node, decorate it and associate it with the subpool
+      --  list of Pool.
+
+      N_Ptr := new SP_Node;
+
+      Subpool.Owner := Pool'Unchecked_Access;
+      N_Ptr.Subpool := Subpool;
+
+      Attach (N_Ptr, Pool.Subpools'Unchecked_Access);
+   end Set_Pool_Of_Subpool;
+
+end System.Storage_Pools.Subpools;
Index: s-stposu.ads
===================================================================
--- s-stposu.ads	(revision 0)
+++ s-stposu.ads	(revision 0)
@@ -0,0 +1,255 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         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         --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--            Copyright (C) 2011, Free Software Foundation, Inc.            --
+--                                                                          --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the  contents of the part following the private keyword. --
+--                                                                          --
+-- 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.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with System.Finalization_Masters;
+with System.Storage_Elements;
+
+package System.Storage_Pools.Subpools is
+   pragma Preelaborate (System.Storage_Pools.Subpools);
+
+   type Root_Storage_Pool_With_Subpools is abstract
+     new Root_Storage_Pool with private;
+   --  The base for all implementations of Storage_Pool_With_Subpools. This
+   --  type is Limited_Controlled by derivation. To use subpools, an access
+   --  type must be associated with an implementation descending from type
+   --  Root_Storage_Pool_With_Subpools.
+
+   type Root_Subpool is abstract tagged limited private;
+   --  The base for all implementations of Subpool. Objects of this type are
+   --  managed by the pool_with_subpools.
+
+   type Subpool_Handle is access all Root_Subpool'Class;
+   for Subpool_Handle'Storage_Size use 0;
+   --  Since subpools are limited types by definition, a handle is instead used
+   --  to manage subpool abstractions.
+
+   overriding procedure Allocate
+     (Pool                     : in out Root_Storage_Pool_With_Subpools;
+      Storage_Address          : out System.Address;
+      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.
+
+   procedure Allocate_From_Subpool
+     (Pool                     : in out Root_Storage_Pool_With_Subpools;
+      Storage_Address          : out System.Address;
+      Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
+      Alignment                : System.Storage_Elements.Storage_Count;
+      Subpool                  : not null Subpool_Handle)
+   is abstract;
+
+   --  ??? This precondition causes errors in simple tests, disabled for now
+
+--     with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
+   --  This routine requires implementation. Allocate an object described by
+   --  Size_In_Storage_Elements and Alignment on a subpool.
+
+   function Create_Subpool
+     (Pool         : in out Root_Storage_Pool_With_Subpools;
+      Storage_Size : Storage_Elements.Storage_Count :=
+                     Storage_Elements.Storage_Count'Last)
+   return not null Subpool_Handle
+   is abstract;
+   --  This routine requires implementation. Create a subpool within the given
+   --  pool_with_subpools.
+
+   overriding procedure Deallocate
+     (Pool                     : in out Root_Storage_Pool_With_Subpools;
+      Storage_Address          : System.Address;
+      Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
+      Alignment                : System.Storage_Elements.Storage_Count)
+   is null;
+
+   procedure Deallocate_Subpool
+     (Pool    : in out Root_Storage_Pool_With_Subpools;
+      Subpool : in out Subpool_Handle)
+   is abstract;
+
+   --  ??? This precondition causes errors in simple tests, disabled for now
+
+--     with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
+   --  This routine requires implementation. Reclaim the storage a particular
+   --  subpool occupies in a pool_with_subpools. This routine is called by
+   --  Ada.Unchecked_Deallocate_Subpool.
+
+   function Default_Subpool_For_Pool
+     (Pool : Root_Storage_Pool_With_Subpools)
+   return not null Subpool_Handle
+   is abstract;
+   --  This routine requires implementation. Returns a common subpool used for
+   --  allocations without Subpool_Handle_name in the allocator.
+
+   function Pool_Of_Subpool
+     (Subpool : not null Subpool_Handle)
+   return access Root_Storage_Pool_With_Subpools'Class;
+   --  Return the owner of the subpool
+
+   procedure Set_Pool_Of_Subpool
+     (Subpool : not null Subpool_Handle;
+      Pool    : in out Root_Storage_Pool_With_Subpools'Class);
+   --  Set the owner of the subpool. This is intended to be called from
+   --  Create_Subpool or similar subpool constructors. Raises Program_Error
+   --  if the subpool already belongs to a pool.
+
+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  |      :
+   --  :      +------+  +------+  +------+             +------+      :
+   --  :      :      :  :      :  :      :             :      :      :
+   --  :      :      :  :      :  :      :             :      :      :
+   --  :      '......'  '......'  '......'             '......'      :
+   --  :                                                             :
+   --  '.............................................................'
+
+   --  Subpool list types. Each pool_with_subpools contains a list of subpools.
+
+   type SP_Node;
+   type SP_Node_Ptr is access all SP_Node;
+
+   type SP_Node is record
+      Prev    : SP_Node_Ptr := null;
+      Next    : SP_Node_Ptr := null;
+      Subpool : Subpool_Handle := null;
+   end record;
+
+   --  Root_Storage_Pool_With_Subpools internal structure
+
+   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
+
+      Finalization_Started : Boolean := False;
+      pragma Atomic (Finalization_Started);
+      --  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;
+
+   --  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.
+
+   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
+   end record;
+
+   --  ??? Once Storage_Pools.Allocate_Any is removed, this should be renamed
+   --  to Allocate_Any.
+
+   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;
+      Addr            : out System.Address;
+      Storage_Size    : System.Storage_Elements.Storage_Count;
+      Alignment       : System.Storage_Elements.Storage_Count;
+      Is_Controlled   : Boolean := True);
+   --  Compiler interface. This version of Allocate handles all possible cases,
+   --  either on a pool or a pool_with_subpools.
+
+   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);
+   --  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);
+   --  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
+
+end System.Storage_Pools.Subpools;
Index: a-undesu.adb
===================================================================
--- a-undesu.adb	(revision 0)
+++ a-undesu.adb	(revision 0)
@@ -0,0 +1,36 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--     A D A . U N C H E C K E D _ D E A L L O C A T E _ S U B P O O L      --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--            Copyright (C) 2011, Free Software Foundation, Inc.            --
+--                                                                          --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT.  In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification,  provided that if you redistribute a --
+-- modified version,  any changes that you have made are clearly indicated. --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  ??? What is the header version here, see a-uncdea.adb. No GPL?
+
+with System.Storage_Pools.Subpools; use System.Storage_Pools.Subpools;
+
+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);
+end Ada.Unchecked_Deallocate_Subpool;
Index: a-undesu.ads
===================================================================
--- a-undesu.ads	(revision 0)
+++ a-undesu.ads	(revision 0)
@@ -0,0 +1,23 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--     A D A . U N C H E C K E D _ D E A L L O C A T E _ S U B P O O L      --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--            Copyright (C) 2011, Free Software Foundation, Inc.            --
+--                                                                          --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT.  In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification,  provided that if you redistribute a --
+-- modified version,  any changes that you have made are clearly indicated. --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  ??? What is the header version here, see a-uncdea.ads. No GPL?
+
+with System.Storage_Pools.Subpools;
+
+procedure Ada.Unchecked_Deallocate_Subpool
+  (Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle);
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 178163)
+++ exp_ch4.adb	(working copy)
@@ -444,12 +444,15 @@
          return;
       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 collection which appears on the declarations
-      --  of the enclosing semantic unit.
+      --  types receive a special finalization master which appears in the
+      --  declarations of the enclosing semantic unit.
 
       if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
-        and then No (Associated_Collection (Ptr_Typ))
+        and then No (Finalization_Master (Ptr_Typ))
         and then
           (not Restriction_Active (No_Nested_Finalization)
              or else Is_Library_Level_Entity (Ptr_Typ))
@@ -466,7 +469,7 @@
                Scop := Corresponding_Spec (Parent (Parent (Parent (Scop))));
             end if;
 
-            Build_Finalization_Collection
+            Build_Finalization_Master
               (Typ        => Ptr_Typ,
                Ins_Node   => First_Declaration_Of_Current_Unit,
                Encl_Scope => Scop);
@@ -481,7 +484,7 @@
       --  Since the temporary object reuses the original allocator, generate a
       --  custom Allocate routine for the temporary.
 
-      if Present (Associated_Collection (Ptr_Typ)) then
+      if Present (Finalization_Master (Ptr_Typ)) then
          Build_Allocate_Deallocate_Proc
            (N           => Temp_Decl,
             Is_Allocate => True);
@@ -858,14 +861,14 @@
                Complete_Controlled_Allocation (Temp_Decl);
                Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
 
-               --  Attach the object to the associated finalization collection.
+               --  Attach the object to the associated finalization master.
                --  This is done manually on .NET/JVM since those compilers do
                --  no support pools and can't benefit from internally generated
                --  Allocate / Deallocate procedures.
 
                if VM_Target /= No_VM
                  and then Is_Controlled (DesigT)
-                 and then Present (Associated_Collection (PtrT))
+                 and then Present (Finalization_Master (PtrT))
                then
                   Insert_Action (N,
                     Make_Attach_Call (
@@ -888,14 +891,14 @@
                Insert_Action (N, Temp_Decl);
                Complete_Controlled_Allocation (Temp_Decl);
 
-               --  Attach the object to the associated finalization collection.
+               --  Attach the object to the associated finalization master.
                --  This is done manually on .NET/JVM since those compilers do
                --  no support pools and can't benefit from internally generated
                --  Allocate / Deallocate procedures.
 
                if VM_Target /= No_VM
                  and then Is_Controlled (DesigT)
-                 and then Present (Associated_Collection (PtrT))
+                 and then Present (Finalization_Master (PtrT))
                then
                   Insert_Action (N,
                     Make_Attach_Call (
@@ -931,8 +934,7 @@
                --  Inherit the allocation-related attributes from the original
                --  access type.
 
-               Set_Associated_Collection (Def_Id,
-                 Associated_Collection (PtrT));
+               Set_Finalization_Master (Def_Id, Finalization_Master (PtrT));
 
                Set_Associated_Storage_Pool (Def_Id,
                  Associated_Storage_Pool (PtrT));
@@ -1083,25 +1085,6 @@
                          Prefix => New_Reference_To (Temp, Loc))),
                    Typ => T));
             end if;
-
-            --  Generate:
-            --    Set_Finalize_Address_Ptr
-            --      (Collection, <Finalize_Address>'Unrestricted_Access)
-
-            --  Since .NET/JVM compilers do not support address arithmetic,
-            --  this call is skipped. The same is done for CodePeer because
-            --  Finalize_Address is never generated.
-
-            if VM_Target = No_VM
-              and then not CodePeer_Mode
-              and then Present (Associated_Collection (PtrT))
-            then
-               Insert_Action (N,
-                 Make_Set_Finalize_Address_Ptr_Call
-                   (Loc     => Loc,
-                    Typ     => T,
-                    Ptr_Typ => PtrT));
-            end if;
          end if;
 
          Rewrite (N, New_Reference_To (Temp, Loc));
@@ -1139,14 +1122,14 @@
          Complete_Controlled_Allocation (Temp_Decl);
          Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
 
-         --  Attach the object to the associated finalization collection. This
-         --  is done manually on .NET/JVM since those compilers do no support
+         --  Attach the object to the associated finalization master. Thisis
+         --  done manually on .NET/JVM since those compilers do no support
          --  pools and cannot benefit from internally generated Allocate and
          --  Deallocate procedures.
 
          if VM_Target /= No_VM
            and then Is_Controlled (DesigT)
-           and then Present (Associated_Collection (PtrT))
+           and then Present (Finalization_Master (PtrT))
          then
             Insert_Action (N,
               Make_Attach_Call
@@ -3564,7 +3547,7 @@
             --  do not support pools, this step is skipped.
 
             if VM_Target = No_VM
-              and then Present (Associated_Collection (PtrT))
+              and then Present (Finalization_Master (PtrT))
             then
                Build_Allocate_Deallocate_Proc
                  (N           => Parent (N),
@@ -3858,39 +3841,22 @@
                       (Obj_Ref => New_Copy_Tree (Init_Arg1),
                        Typ     => T));
 
-                  if Present (Associated_Collection (PtrT)) then
+                  --  Special processing for .NET/JVM, the allocated object is
+                  --  attached to the finalization master. Generate:
 
-                     --  Special processing for .NET/JVM, the allocated object
-                     --  is attached to the finalization collection. 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.
 
-                     --  Types derived from [Limited_]Controlled are the only
-                     --  ones considered since they have fields Prev and Next.
-
-                     if VM_Target /= No_VM then
-                        if Is_Controlled (T) then
-                           Insert_Action (N,
-                             Make_Attach_Call
-                               (Obj_Ref => New_Copy_Tree (Init_Arg1),
-                                Ptr_Typ => PtrT));
-                        end if;
-
-                     --  Default case, generate:
-
-                     --    Set_Finalize_Address_Ptr
-                     --      (Pool, <Finalize_Address>'Unrestricted_Access)
-
-                     --  Do not generate the above for CodePeer compilations
-                     --  because Finalize_Address is never built.
-
-                     elsif not CodePeer_Mode then
-                        Insert_Action (N,
-                          Make_Set_Finalize_Address_Ptr_Call
-                            (Loc     => Loc,
-                             Typ     => T,
-                             Ptr_Typ => PtrT));
-                     end if;
+                  if VM_Target /= No_VM
+                    and then Present (Finalization_Master (PtrT))
+                    and then Is_Controlled (T)
+                  then
+                     Insert_Action (N,
+                       Make_Attach_Call
+                         (Obj_Ref => New_Copy_Tree (Init_Arg1),
+                          Ptr_Typ => PtrT));
                   end if;
                end if;
 
Index: s-stopoo.adb
===================================================================
--- s-stopoo.adb	(revision 178155)
+++ s-stopoo.adb	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---             Copyright (C) 2009 Free Software Foundation, Inc.            --
+--          Copyright (C) 2009-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- --
@@ -37,13 +37,12 @@
 
    procedure Allocate_Any
     (Pool                     : in out Root_Storage_Pool'Class;
-     Storage_Address          : out Address;
+     Storage_Address          : out System.Address;
      Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
      Alignment                : System.Storage_Elements.Storage_Count)
    is
    begin
-      Allocate
-        (Pool, Storage_Address, Size_In_Storage_Elements, Alignment);
+      Allocate (Pool, Storage_Address, Size_In_Storage_Elements, Alignment);
    end Allocate_Any;
 
    --------------------
@@ -52,12 +51,12 @@
 
    procedure Deallocate_Any
     (Pool                     : in out Root_Storage_Pool'Class;
-     Storage_Address          : Address;
+     Storage_Address          : System.Address;
      Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
      Alignment                : System.Storage_Elements.Storage_Count)
    is
    begin
-      Deallocate
-        (Pool, Storage_Address, Size_In_Storage_Elements, Alignment);
+      Deallocate (Pool, Storage_Address, Size_In_Storage_Elements, Alignment);
    end Deallocate_Any;
+
 end System.Storage_Pools;
Index: s-stopoo.ads
===================================================================
--- s-stopoo.ads	(revision 178155)
+++ s-stopoo.ads	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -44,14 +44,14 @@
 
    procedure Allocate
      (Pool                     : in out Root_Storage_Pool;
-      Storage_Address          : out Address;
+      Storage_Address          : out System.Address;
       Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
       Alignment                : System.Storage_Elements.Storage_Count)
    is abstract;
 
    procedure Deallocate
      (Pool                     : in out Root_Storage_Pool;
-      Storage_Address          : Address;
+      Storage_Address          : System.Address;
       Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
       Alignment                : System.Storage_Elements.Storage_Count)
    is abstract;
@@ -62,6 +62,13 @@
    is abstract;
 
 private
+   type Root_Storage_Pool is abstract
+     new Ada.Finalization.Limited_Controlled with null record;
+
+   --  ??? Are these two still needed? It might be possible to use Subpools.
+   --  Allocate_Any_Controlled / Deallocate_Any_Controlled for non-controlled
+   --  objects.
+
    --  The following two procedures support the use of class-wide pool
    --  objects in storage pools. When a local type is given a class-wide
    --  storage pool, allocation and deallocation for the type must dispatch
@@ -71,16 +78,14 @@
 
    procedure Allocate_Any
     (Pool                     : in out Root_Storage_Pool'Class;
-     Storage_Address          : out Address;
+     Storage_Address          : out System.Address;
      Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
      Alignment                : System.Storage_Elements.Storage_Count);
 
    procedure Deallocate_Any
     (Pool                     : in out Root_Storage_Pool'Class;
-     Storage_Address          : Address;
+     Storage_Address          : System.Address;
      Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
      Alignment                : System.Storage_Elements.Storage_Count);
 
-   type Root_Storage_Pool is abstract
-     new Ada.Finalization.Limited_Controlled with null record;
 end System.Storage_Pools;
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb	(revision 178155)
+++ exp_ch6.adb	(working copy)
@@ -110,14 +110,14 @@
    --  Adds Extra_Actual as a named parameter association for the formal
    --  Extra_Formal in Subprogram_Call.
 
-   procedure Add_Collection_Actual_To_Build_In_Place_Call
+   procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
      (Func_Call : Node_Id;
       Func_Id   : Entity_Id;
       Ptr_Typ   : Entity_Id := Empty);
    --  Ada 2005 (AI-318-02): If the result type of a build-in-place call needs
    --  finalization actions, add an actual parameter which is a pointer to the
-   --  finalization collection of the caller. If Ptr_Typ is left Empty, this
-   --  will result in an automatic "null" value for the actual.
+   --  finalization master of the caller. If Ptr_Typ is left Empty, this will
+   --  result in an automatic "null" value for the actual.
 
    procedure Add_Task_Actuals_To_Build_In_Place_Call
      (Function_Call : Node_Id;
@@ -340,30 +340,30 @@
         (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual);
    end Add_Alloc_Form_Actual_To_Build_In_Place_Call;
 
-   --------------------------------------------------
-   -- Add_Collection_Actual_To_Build_In_Place_Call --
-   --------------------------------------------------
+   -----------------------------------------------------------
+   -- Add_Finalization_Master_Actual_To_Build_In_Place_Call --
+   -----------------------------------------------------------
 
-   procedure Add_Collection_Actual_To_Build_In_Place_Call
+   procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
      (Func_Call : Node_Id;
       Func_Id   : Entity_Id;
       Ptr_Typ   : Entity_Id := Empty)
    is
    begin
-      if not Needs_BIP_Collection (Func_Id) then
+      if not Needs_BIP_Finalization_Master (Func_Id) then
          return;
       end if;
 
       declare
          Formal : constant Entity_Id :=
-                    Build_In_Place_Formal (Func_Id, BIP_Collection);
+                    Build_In_Place_Formal (Func_Id, BIP_Finalization_Master);
          Loc    : constant Source_Ptr := Sloc (Func_Call);
 
          Actual    : Node_Id;
          Desig_Typ : Entity_Id;
 
       begin
-         --  Case where the context does not require an actual collection
+         --  Case where the context does not require an actual master
 
          if No (Ptr_Typ) then
             Actual := Make_Null (Loc);
@@ -372,9 +372,9 @@
             Desig_Typ := Directly_Designated_Type (Ptr_Typ);
 
             --  Check for a library-level access type whose designated type has
-            --  supressed finalization. Such an access types lack a collection.
+            --  supressed finalization. Such an access types lack a master.
             --  Pass a null actual to the callee in order to signal a missing
-            --  collection.
+            --  master.
 
             if Is_Library_Level_Entity (Ptr_Typ)
               and then Finalize_Storage_Only (Desig_Typ)
@@ -385,28 +385,28 @@
 
             elsif Needs_Finalization (Desig_Typ) then
 
-               --  The general mechanism of creating finalization collections
-               --  for anonymous access types is disabled by default, otherwise
-               --  collections will pop all over the place. Such types use
-               --  context-specific collections.
+               --  The general mechanism of creating finalization masters for
+               --  anonymous access types is disabled by default, otherwise
+               --  finalization masters will pop all over the place. Such types
+               --  use context-specific masters.
 
                if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
-                 and then No (Associated_Collection (Ptr_Typ))
+                 and then No (Finalization_Master (Ptr_Typ))
                then
-                  Build_Finalization_Collection
+                  Build_Finalization_Master
                     (Typ        => Ptr_Typ,
                      Ins_Node   => Associated_Node_For_Itype (Ptr_Typ),
                      Encl_Scope => Scope (Ptr_Typ));
                end if;
 
-               --  Access-to-controlled types should always have a collection
+               --  Access-to-controlled types should always have a master
 
-               pragma Assert (Present (Associated_Collection (Ptr_Typ)));
+               pragma Assert (Present (Finalization_Master (Ptr_Typ)));
 
                Actual :=
                  Make_Attribute_Reference (Loc,
                    Prefix =>
-                     New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
+                     New_Reference_To (Finalization_Master (Ptr_Typ), Loc),
                    Attribute_Name => Name_Unrestricted_Access);
 
             --  Tagged types
@@ -423,7 +423,7 @@
 
          Add_Extra_Actual_To_Call (Func_Call, Formal, Actual);
       end;
-   end Add_Collection_Actual_To_Build_In_Place_Call;
+   end Add_Finalization_Master_Actual_To_Build_In_Place_Call;
 
    ------------------------------
    -- Add_Extra_Actual_To_Call --
@@ -559,15 +559,15 @@
    function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is
    begin
       case Kind is
-         when BIP_Alloc_Form       =>
+         when BIP_Alloc_Form          =>
             return "BIPalloc";
-         when BIP_Collection       =>
-            return "BIPcollection";
-         when BIP_Master           =>
+         when BIP_Finalization_Master =>
+            return "BIPfinalizationmaster";
+         when BIP_Master              =>
             return "BIPmaster";
-         when BIP_Activation_Chain =>
+         when BIP_Activation_Chain    =>
             return "BIPactivationchain";
-         when BIP_Object_Access    =>
+         when BIP_Object_Access       =>
             return "BIPaccess";
       end case;
    end BIP_Formal_Suffix;
@@ -2105,10 +2105,10 @@
          end if;
       end if;
 
-      --  Detect the following code in Ada.Finalization.Heap_Management only
-      --  on .NET/JVM targets:
+      --  Detect the following code in System.Finalization_Masters only on
+      --  .NET/JVM targets:
       --
-      --    procedure Finalize (Collection : in out Finalization_Collection) is
+      --    procedure Finalize (Master : in out Finalization_Master) is
       --    begin
       --       . . .
       --       begin
@@ -2124,7 +2124,7 @@
         and then Ekind (Scope (Curr_S)) = E_Procedure
         and then Chars (Scope (Curr_S)) = Name_Finalize
         and then Etype (First_Formal (Scope (Curr_S))) =
-                   RTE (RE_Finalization_Collection)
+                   RTE (RE_Finalization_Master)
       then
          declare
             Deep_Fin : constant Entity_Id :=
@@ -4393,20 +4393,20 @@
          Ret_Typ    : Entity_Id;
          Alloc_Expr : Node_Id) return Node_Id;
       --  Create the statements necessary to allocate a return object on the
-      --  caller's collection. The collection is available through implicit
-      --  parameter BIPcollection.
+      --  caller's master. The master is available through implicit parameter
+      --  BIPfinalizationmaster.
       --
-      --    if BIPcollection /= null then
+      --    if BIPfinalizationmaster /= null then
       --       declare
       --          type Ptr_Typ is access Ret_Typ;
       --          for Ptr_Typ'Storage_Pool use
-      --                Base_Pool (BIPcollection.all).all;
+      --                Base_Pool (BIPfinalizationmaster.all).all;
       --          Local : Ptr_Typ;
       --
       --       begin
       --          procedure Allocate (...) is
       --          begin
-      --             Ada.Finalization.Heap_Management.Allocate (...);
+      --             System.Storage_Pools.Subpools.Allocate_Any (...);
       --          end Allocate;
       --
       --          Local := <Alloc_Expr>;
@@ -4439,17 +4439,18 @@
       is
       begin
          --  Processing for build-in-place object allocation. This is disabled
-         --  on .NET/JVM because pools are not supported.
+         --  on .NET/JVM because the targets do not support pools.
 
          if VM_Target = No_VM
            and then Is_Build_In_Place_Function (Func_Id)
            and then Needs_Finalization (Ret_Typ)
          then
             declare
-               Collect : constant Entity_Id :=
-                           Build_In_Place_Formal (Func_Id, BIP_Collection);
-               Decls   : constant List_Id := New_List;
-               Stmts   : constant List_Id := New_List;
+               Decls      : constant List_Id := New_List;
+               Fin_Mas_Id : constant Entity_Id :=
+                              Build_In_Place_Formal
+                                (Func_Id, BIP_Finalization_Master);
+               Stmts      : constant List_Id := New_List;
 
                Local_Id : Entity_Id;
                Pool_Id  : Entity_Id;
@@ -4457,7 +4458,7 @@
 
             begin
                --  Generate:
-               --    Pool_Id renames Base_Pool (BIPcollection.all).all;
+               --    Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
 
                Pool_Id := Make_Temporary (Loc, 'P');
 
@@ -4474,11 +4475,12 @@
                              New_Reference_To (RTE (RE_Base_Pool), Loc),
                            Parameter_Associations => New_List (
                              Make_Explicit_Dereference (Loc,
-                               Prefix => New_Reference_To (Collect, Loc)))))));
+                               Prefix =>
+                                 New_Reference_To (Fin_Mas_Id, Loc)))))));
 
                --  Create an access type which uses the storage pool of the
-               --  caller's collection. This additional type is necessary
-               --  because the collection cannot be associated with the type
+               --  caller's master. This additional type is necessary because
+               --  the finalization master cannot be associated with the type
                --  of the temporary. Otherwise the secondary stack allocation
                --  will fail.
 
@@ -4495,11 +4497,11 @@
                        Subtype_Indication =>
                          New_Reference_To (Ret_Typ, Loc))));
 
-               --  Perform minor decoration in order to set the collection and
-               --  the storage pool attributes.
+               --  Perform minor decoration in order to set the master and the
+               --  storage pool attributes.
 
                Set_Ekind (Ptr_Typ, E_Access_Type);
-               Set_Associated_Collection   (Ptr_Typ, Collect);
+               Set_Finalization_Master     (Ptr_Typ, Fin_Mas_Id);
                Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
 
                --  Create the temporary, generate:
@@ -4534,12 +4536,12 @@
                        New_Reference_To (Local_Id, Loc))));
 
                --  Wrap the allocation in a block. This is further conditioned
-               --  by checking the caller collection at runtime. A null value
-               --  indicates a non-existent collection, most likely due to a
-               --  Finalize_Storage_Only allocation.
+               --  by checking the caller finalization master at runtime. A
+               --  null value indicates a non-existent master, most likely due
+               --  to a Finalize_Storage_Only allocation.
 
                --  Generate:
-               --    if BIPcollection /= null then
+               --    if BIPfinalizationmaster /= null then
                --       declare
                --          <Decls>
                --       begin
@@ -4551,7 +4553,7 @@
                  Make_If_Statement (Loc,
                    Condition       =>
                      Make_Op_Ne (Loc,
-                       Left_Opnd  => New_Reference_To (Collect, Loc),
+                       Left_Opnd  => New_Reference_To (Fin_Mas_Id, Loc),
                        Right_Opnd => Make_Null (Loc)),
 
                    Then_Statements => New_List (
@@ -7110,7 +7112,7 @@
          Add_Alloc_Form_Actual_To_Build_In_Place_Call
            (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
 
-         Add_Collection_Actual_To_Build_In_Place_Call
+         Add_Finalization_Master_Actual_To_Build_In_Place_Call
            (Func_Call, Function_Id, Acc_Type);
 
          Add_Task_Actuals_To_Build_In_Place_Call
@@ -7144,7 +7146,7 @@
          Add_Alloc_Form_Actual_To_Build_In_Place_Call
            (Func_Call, Function_Id, Alloc_Form => Global_Heap);
 
-         Add_Collection_Actual_To_Build_In_Place_Call
+         Add_Finalization_Master_Actual_To_Build_In_Place_Call
            (Func_Call, Function_Id, Acc_Type);
 
          Add_Task_Actuals_To_Build_In_Place_Call
@@ -7157,33 +7159,6 @@
            (Func_Call, Function_Id, Return_Object => Empty);
       end if;
 
-      --  If the build-in-place function call returns a controlled object, the
-      --  finalization collection will require a reference to routine Finalize_
-      --  Address of the designated type. Setting this attribute is done in the
-      --  same manner to expansion of allocators.
-
-      if Needs_Finalization (Result_Subt) then
-
-         --  Controlled types with supressed finalization do not need to
-         --  associate the address of their Finalize_Address primitives with a
-         --  collection since they do not need a collection to begin with.
-
-         if Is_Library_Level_Entity (Acc_Type)
-           and then Finalize_Storage_Only (Result_Subt)
-         then
-            null;
-
-         --  Do not generate the call to Make_Set_Finalize_Address_Ptr for
-         --  CodePeer compilations because Finalize_Address is never built.
-
-         elsif not CodePeer_Mode then
-            Insert_Action (Allocator,
-              Make_Set_Finalize_Address_Ptr_Call (Loc,
-                Typ     => Etype (Function_Id),
-                Ptr_Typ => Acc_Type));
-         end if;
-      end if;
-
       --  Finally, replace the allocator node with a reference to the result
       --  of the function call itself (which will effectively be an access
       --  to the object created by the allocator).
@@ -7310,7 +7285,7 @@
          Add_Alloc_Form_Actual_To_Build_In_Place_Call
            (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
 
-         Add_Collection_Actual_To_Build_In_Place_Call
+         Add_Finalization_Master_Actual_To_Build_In_Place_Call
            (Func_Call, Function_Id);
 
          Add_Task_Actuals_To_Build_In_Place_Call
@@ -7334,7 +7309,7 @@
          Add_Alloc_Form_Actual_To_Build_In_Place_Call
            (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
 
-         Add_Collection_Actual_To_Build_In_Place_Call
+         Add_Finalization_Master_Actual_To_Build_In_Place_Call
            (Func_Call, Function_Id);
 
          Add_Task_Actuals_To_Build_In_Place_Call
@@ -7412,7 +7387,7 @@
       Add_Alloc_Form_Actual_To_Build_In_Place_Call
         (Func_Call, Func_Id, Alloc_Form => Caller_Allocation);
 
-      Add_Collection_Actual_To_Build_In_Place_Call
+      Add_Finalization_Master_Actual_To_Build_In_Place_Call
         (Func_Call, Func_Id);
 
       Add_Task_Actuals_To_Build_In_Place_Call
@@ -7625,7 +7600,7 @@
          Establish_Transient_Scope (Object_Decl, Sec_Stack => True);
       end if;
 
-      Add_Collection_Actual_To_Build_In_Place_Call
+      Add_Finalization_Master_Actual_To_Build_In_Place_Call
         (Func_Call, Function_Id);
 
       if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement
@@ -7773,11 +7748,13 @@
       end if;
    end Make_Build_In_Place_Call_In_Object_Declaration;
 
-   --------------------------
-   -- Needs_BIP_Collection --
-   --------------------------
+   -----------------------------------
+   -- Needs_BIP_Finalization_Master --
+   -----------------------------------
 
-   function Needs_BIP_Collection (Func_Id : Entity_Id) return Boolean is
+   function Needs_BIP_Finalization_Master
+     (Func_Id : Entity_Id) return Boolean
+   is
       pragma Assert (Is_Build_In_Place_Function (Func_Id));
       Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
 
@@ -7785,6 +7762,6 @@
       return
         not Restriction_Active (No_Finalization)
           and then Needs_Finalization (Func_Typ);
-   end Needs_BIP_Collection;
+   end Needs_BIP_Finalization_Master;
 
 end Exp_Ch6;
Index: exp_ch6.ads
===================================================================
--- exp_ch6.ads	(revision 178155)
+++ exp_ch6.ads	(working copy)
@@ -68,9 +68,9 @@
       --  caller or callee, and if the callee, whether to use the secondary
       --  stack or the heap. See Create_Extra_Formals.
 
-      BIP_Collection,
+      BIP_Finalization_Master,
       --  Present if result type needs finalization. Pointer to caller's
-      --  finalization collection.
+      --  finalization master.
 
       BIP_Master,
       --  Present if result type contains tasks. Master associated with
@@ -163,8 +163,8 @@
    --  for which Is_Build_In_Place_Call is True, or an N_Qualified_Expression
    --  node applied to such a function call.
 
-   function Needs_BIP_Collection (Func_Id : Entity_Id) return Boolean;
+   function Needs_BIP_Finalization_Master (Func_Id : Entity_Id) return Boolean;
    --  Ada 2005 (AI-318-02): Return True if the function needs a finalization
-   --  collection implicit parameter.
+   --  master implicit parameter.
 
 end Exp_Ch6;
Index: exp_ch13.adb
===================================================================
--- exp_ch13.adb	(revision 178155)
+++ exp_ch13.adb	(working copy)
@@ -230,7 +230,7 @@
          return;
       end if;
 
-      --  Use the base type to perform the collection check
+      --  Use the base type to perform the check for finalization master
 
       Typ := Etype (Expr);
 
@@ -248,10 +248,10 @@
 
       --  Do not create a custom Deallocate when freeing an object with
       --  suppressed finalization. In such cases the object is never attached
-      --  to a collection, so it does not need to be detached. Use a regular
-      --  free statement instead.
+      --  to a master, so it does not need to be detached. Use a regular free
+      --  statement instead.
 
-      if No (Associated_Collection (Typ)) then
+      if No (Finalization_Master (Typ)) then
          return;
       end if;
 
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb	(revision 178165)
+++ sem_ch6.adb	(working copy)
@@ -6080,14 +6080,13 @@
             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:
Index: Makefile.rtl
===================================================================
--- Makefile.rtl	(revision 178155)
+++ Makefile.rtl	(working copy)
@@ -154,7 +154,6 @@
   a-envvar$(objext) \
   a-except$(objext) \
   a-exctra$(objext) \
-  a-fihema$(objext) \
   a-finali$(objext) \
   a-flteio$(objext) \
   a-fwteio$(objext) \
@@ -290,6 +289,7 @@
   a-tiunio$(objext) \
   a-unccon$(objext) \
   a-uncdea$(objext) \
+  a-undesu$(objext) \
   a-wichha$(objext) \
   a-wichun$(objext) \
   a-widcha$(objext) \
@@ -495,6 +495,7 @@
   s-ficobl$(objext) \
   s-fileio$(objext) \
   s-filofl$(objext) \
+  s-finmas$(objext) \
   s-finroo$(objext) \
   s-fishfl$(objext) \
   s-flocon$(objext) \
@@ -611,6 +612,7 @@
   s-stchop$(objext) \
   s-stoele$(objext) \
   s-stopoo$(objext) \
+  s-stposu$(objext) \
   s-stratt$(objext) \
   s-strhas$(objext) \
   s-string$(objext) \
Index: s-finmas.adb
===================================================================
--- s-finmas.adb	(revision 0)
+++ s-finmas.adb	(revision 0)
@@ -0,0 +1,214 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--           S Y S T E M . F I N A L I Z A T I O N _ M A S T E R S          --
+--                                                                          --
+--                                 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.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions;          use Ada.Exceptions;
+
+with System.Soft_Links;       use System.Soft_Links;
+with System.Storage_Elements; use System.Storage_Elements;
+
+package body System.Finalization_Masters is
+
+   ---------------------------
+   -- Add_Offset_To_Address --
+   ---------------------------
+
+   function Add_Offset_To_Address
+     (Addr   : System.Address;
+      Offset : System.Storage_Elements.Storage_Offset) return System.Address
+   is
+   begin
+      return System.Storage_Elements."+" (Addr, Offset);
+   end Add_Offset_To_Address;
+
+   ------------
+   -- Attach --
+   ------------
+
+   procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is
+   begin
+      Lock_Task.all;
+
+      L.Next.Prev := N;
+      N.Next := L.Next;
+      L.Next := N;
+      N.Prev := L;
+
+      Unlock_Task.all;
+
+      --  Note: No need to unlock in case of an exception because the above
+      --  code can never raise one.
+   end Attach;
+
+   ---------------
+   -- Base_Pool --
+   ---------------
+
+   function Base_Pool
+     (Master : Finalization_Master) return Any_Storage_Pool_Ptr
+   is
+   begin
+      return Master.Base_Pool;
+   end Base_Pool;
+
+   ------------
+   -- Detach --
+   ------------
+
+   procedure Detach (N : not null FM_Node_Ptr) is
+   begin
+      --  N must be attached to some list
+
+      pragma Assert (N.Next /= null and then N.Prev /= null);
+
+      Lock_Task.all;
+
+      N.Prev.Next := N.Next;
+      N.Next.Prev := N.Prev;
+
+      Unlock_Task.all;
+
+      --  Note: No need to unlock in case of an exception because the above
+      --  code can never raise one.
+   end Detach;
+
+   --------------
+   -- Finalize --
+   --------------
+
+   overriding procedure Finalize (Master : in out Finalization_Master) is
+      Curr_Ptr : FM_Node_Ptr;
+      Ex_Occur : Exception_Occurrence;
+      Obj_Addr : Address;
+      Raised   : Boolean := False;
+
+   begin
+      --  It is possible for multiple tasks to cause the finalization of the
+      --  same master. Let only one task finalize the objects.
+
+      if Master.Finalization_Started then
+         return;
+      end if;
+
+      --  Lock the master to prevent any allocations while the objects are
+      --  being finalized. The master remains locked because either the master
+      --  is explicitly deallocated or the associated access type is about to
+      --  go out of scope.
+
+      Master.Finalization_Started := True;
+
+      --  Skip the dummy head
+
+      Curr_Ptr := Master.Objects.Next;
+      while Curr_Ptr /= Master.Objects'Unchecked_Access loop
+         begin
+            --  If primitive Finalize_Address is not set, then the expansion of
+            --  the designated type or that of the allocator failed. This is a
+            --  serious error.
+
+            --  Note: The Program_Error must be raised from the same block as
+            --  the finalization call. If Finalize_Address is not present for
+            --  a particular object, this should not stop the finalization of
+            --  the remaining objects.
+
+            if Curr_Ptr.Finalize_Address = null then
+               raise Program_Error
+                 with "primitive Finalize_Address not available";
+
+            --  Skip the list header in order to offer proper object layout for
+            --  finalization and call Finalize_Address.
+
+            else
+               Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
+               Curr_Ptr.Finalize_Address (Obj_Addr);
+            end if;
+
+         exception
+            when Fin_Occur : others =>
+               if not Raised then
+                  Raised := True;
+                  Save_Occurrence (Ex_Occur, Fin_Occur);
+               end if;
+         end;
+
+         Curr_Ptr := Curr_Ptr.Next;
+      end loop;
+
+      --  If the finalization of a particular object failed or Finalize_Address
+      --  was not set, reraise the exception now.
+
+      if Raised then
+         Reraise_Occurrence (Ex_Occur);
+      end if;
+   end Finalize;
+
+   -----------------
+   -- Header_Size --
+   -----------------
+
+   function Header_Size return System.Storage_Elements.Storage_Count is
+   begin
+      return FM_Node'Size / Storage_Unit;
+   end Header_Size;
+
+   -------------------
+   -- Header_Offset --
+   -------------------
+
+   function Header_Offset return System.Storage_Elements.Storage_Offset is
+   begin
+      return FM_Node'Size / Storage_Unit;
+   end Header_Offset;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   overriding procedure Initialize (Master : in out Finalization_Master) is
+   begin
+      --  The dummy head must point to itself in both directions
+
+      Master.Objects.Next := Master.Objects'Unchecked_Access;
+      Master.Objects.Prev := Master.Objects'Unchecked_Access;
+   end Initialize;
+
+   -------------------
+   -- Set_Base_Pool --
+   -------------------
+
+   procedure Set_Base_Pool
+     (Master   : in out Finalization_Master;
+      Pool_Ptr : Any_Storage_Pool_Ptr)
+   is
+   begin
+      Master.Base_Pool := Pool_Ptr;
+   end Set_Base_Pool;
+
+end System.Finalization_Masters;
Index: s-finmas.ads
===================================================================
--- s-finmas.ads	(revision 0)
+++ s-finmas.ads	(revision 0)
@@ -0,0 +1,135 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--           S Y S T E M . F I N A L I Z A T I O N _ M A S T E R S          --
+--                                                                          --
+--                                 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.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Finalization;
+with Ada.Unchecked_Conversion;
+
+with System.Storage_Elements;
+with System.Storage_Pools;
+
+package System.Finalization_Masters is
+   pragma Preelaborate (System.Finalization_Masters);
+
+   --  A reference to primitive Finalize_Address. The expander generates an
+   --  implementation of this procedure for each controlled and class-wide
+   --  type. Since controlled objects are simply viewed as addresses once
+   --  allocated through a master, Finalize_Address provides a backward
+   --  indirection from an address to a type-specific context.
+
+   type Finalize_Address_Ptr is access procedure (Obj : System.Address);
+
+   --  Heterogeneous collection type structure. The implementation allows for
+   --  finalizable objects of different base types to be serviced by the same
+   --  master.
+
+   type FM_Node;
+   type FM_Node_Ptr is access all FM_Node;
+
+   type FM_Node is record
+      Prev             : FM_Node_Ptr := null;
+      Next             : FM_Node_Ptr := null;
+      Finalize_Address : Finalize_Address_Ptr := null;
+   end record;
+
+   --  A reference to any derivation from Root_Storage_Pool. Since this type
+   --  may not be used to allocate objects, its storage size is zero.
+
+   type Any_Storage_Pool_Ptr is
+     access System.Storage_Pools.Root_Storage_Pool'Class;
+   for Any_Storage_Pool_Ptr'Storage_Size use 0;
+
+   --  Finalization master type structure. A unique master is associated with
+   --  each access-to-controlled or access-to-class-wide type. Masters also act
+   --  as components of subpools.
+
+   type Finalization_Master is
+     new Ada.Finalization.Limited_Controlled with
+   record
+      Base_Pool : Any_Storage_Pool_Ptr := null;
+      --  A reference to the pool which this finalization master services. This
+      --  field is used in conjunction with the build-in-place machinery.
+
+      Objects : aliased FM_Node;
+      --  A doubly linked list which contains the headers of all controlled
+      --  objects allocated in a [sub]pool.
+
+      Finalization_Started : Boolean := False;
+      pragma Atomic (Finalization_Started);
+      --  A flag used to detect allocations which occur during the finalization
+      --  of a master. The allocations must raise Program_Error. This scenario
+      --  may arise in a multitask environment. The flag is atomic because it
+      --  is accessed without Lock_Task / Unlock_Task.
+   end record;
+
+   type Finalization_Master_Ptr is access all Finalization_Master;
+   for Finalization_Master_Ptr'Storage_Size use 0;
+
+   --  Since RTSfind cannot contain names of the form RE_"+", the following
+   --  routine serves as a wrapper around System.Storage_Elements."+".
+
+   function Add_Offset_To_Address
+     (Addr   : System.Address;
+      Offset : System.Storage_Elements.Storage_Offset) return System.Address;
+
+   function Address_To_FM_Node_Ptr is
+     new Ada.Unchecked_Conversion (Address, FM_Node_Ptr);
+
+   procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr);
+   --  Prepend a node to a specific finalization master
+
+   function Base_Pool
+     (Master : Finalization_Master) return Any_Storage_Pool_Ptr;
+   --  Return a reference to the underlying storage pool on which the master
+   --  operates.
+
+   procedure Detach (N : not null FM_Node_Ptr);
+   --  Remove a node from an arbitrary finalization master
+
+   overriding procedure Finalize (Master : in out Finalization_Master);
+   --  Lock the master to prevent allocations during finalization. Iterate over
+   --  the list of allocated controlled objects, finalizing each one by calling
+   --  its specific Finalize_Address. In the end, deallocate the dummy head.
+
+   function Header_Size return System.Storage_Elements.Storage_Count;
+   --  Return the size of type FM_Node as Storage_Count
+
+   function Header_Offset return System.Storage_Elements.Storage_Offset;
+   --  Return the size of type FM_Node as Storage_Offset
+
+   overriding procedure Initialize (Master : in out Finalization_Master);
+   --  Initialize the dummy head of a finalization master
+
+   procedure Set_Base_Pool
+     (Master   : in out Finalization_Master;
+      Pool_Ptr : Any_Storage_Pool_Ptr);
+   --  Set the underlying pool of a finalization master
+
+end System.Finalization_Masters;
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb	(revision 178176)
+++ exp_ch3.adb	(working copy)
@@ -5482,12 +5482,13 @@
                   Build_Slice_Assignment (Typ);
                end if;
 
-            --  ??? This may not be necessary after all
+            --  ??? Now that masters acts as heterogeneous lists, it might be
+            --  worthed to revisit the global master approach.
 
             elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
               and then Needs_Finalization (Directly_Designated_Type (Comp_Typ))
             then
-               Build_Finalization_Collection (Comp_Typ);
+               Build_Finalization_Master (Comp_Typ);
             end if;
          end if;
 
@@ -5581,8 +5582,8 @@
          return;
       end if;
 
-      --  Generate the body of Finalize_Address. This routine is accessible
-      --  through the TSS mechanism.
+      --  Create the body of TSS primitive Finalize_Address. This automatically
+      --  sets the TSS entry for the class-wide type.
 
       Make_Finalize_Address_Body (Typ);
    end Expand_Freeze_Class_Wide_Type;
@@ -6310,13 +6311,17 @@
          --  compiling a CPP tagged type.
 
          elsif not Restriction_Active (No_Dispatching_Calls) then
-            Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
-            Append_Freeze_Actions (Def_Id, Predef_List);
 
-            --  Create the body of Finalize_Address, a helper routine used in
-            --  conjunction with controlled objects on the heap.
+            --  Create the body of TSS primitive Finalize_Address. This must
+            --  be done before the bodies of all predefined primitives are
+            --  created. If Def_Id is limited, Stream_Input and Streap_Read
+            --  may produce build-in-place allocations and for that the
+            --  expander needs Finalize_Address.
 
             Make_Finalize_Address_Body (Def_Id);
+
+            Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
+            Append_Freeze_Actions (Def_Id, Predef_List);
          end if;
 
          --  Ada 2005 (AI-391): If any wrappers were created for nonoverridden
@@ -6364,7 +6369,7 @@
 
            and then Directly_Designated_Type (Comp_Typ) /= Def_Id
          then
-            Build_Finalization_Collection
+            Build_Finalization_Master
              (Typ        => Comp_Typ,
               Ins_Node   => Parent (Def_Id),
               Encl_Scope => Scope (Def_Id));
@@ -6652,7 +6657,7 @@
                   and then not Is_Frozen (Desig_Type)
                   and then Needs_Finalization (Component_Type (Desig_Type)))
             then
-               Build_Finalization_Collection (Def_Id);
+               Build_Finalization_Master (Def_Id);
             end if;
          end;
 
@@ -8399,7 +8404,7 @@
       end if;
 
       --  All tagged types receive their own Deep_Adjust and Deep_Finalize
-      --  regardless of whether they are controlled or contain controlled
+      --  regardless of whether they are controlled or may contain controlled
       --  components.
 
       --  Do not generate the routines if finalization is disabled
@@ -8414,12 +8419,10 @@
 
       else
          if not Is_Limited_Type (Tag_Typ) then
-            Append_To (Res,
-              Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
+            Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
          end if;
 
-         Append_To (Res,
-           Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
+         Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
       end if;
 
       Predef_List := Res;
@@ -9028,9 +9031,9 @@
       --  to be (implicitly) inherited in that case because it can lead to a VM
       --  exception.
 
-      --  Do not generate stream routines for type Finalization_Collection
-      --  because collection may never appear in types and therefore cannot be
-      --  read or written.
+      --  Do not generate stream routines for type Finalization_Master because
+      --  a master may never appear in types and therefore cannot be read or
+      --  written.
 
       return
           (not Is_Limited_Type (Typ)
@@ -9053,7 +9056,7 @@
         and then RTE_Available (RE_Tag)
         and then No (Type_Without_Stream_Operation (Typ))
         and then RTE_Available (RE_Root_Stream_Type)
-        and then not Is_RTE (Typ, RE_Finalization_Collection);
+        and then not Is_RTE (Typ, RE_Finalization_Master);
    end Stream_Operation_OK;
 
 end Exp_Ch3;
