aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.1/gcc/ada/s-stposu.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.1/gcc/ada/s-stposu.adb')
-rw-r--r--gcc-4.8.1/gcc/ada/s-stposu.adb810
1 files changed, 810 insertions, 0 deletions
diff --git a/gcc-4.8.1/gcc/ada/s-stposu.adb b/gcc-4.8.1/gcc/ada/s-stposu.adb
new file mode 100644
index 000000000..cf43f2232
--- /dev/null
+++ b/gcc-4.8.1/gcc/ada/s-stposu.adb
@@ -0,0 +1,810 @@
+------------------------------------------------------------------------------
+-- --
+-- 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-2012, 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.Address_Image;
+with System.Finalization_Masters; use System.Finalization_Masters;
+with System.IO; use System.IO;
+with System.Soft_Links; use System.Soft_Links;
+with System.Storage_Elements; use System.Storage_Elements;
+
+with System.Storage_Pools.Subpools.Finalization;
+use System.Storage_Pools.Subpools.Finalization;
+
+package body System.Storage_Pools.Subpools is
+
+ Finalize_Address_Table_In_Use : Boolean := False;
+ -- This flag should be set only when a successfull allocation on a subpool
+ -- has been performed and the associated Finalize_Address has been added to
+ -- the hash table in System.Finalization_Masters.
+
+ function Address_To_FM_Node_Ptr is
+ new Ada.Unchecked_Conversion (Address, FM_Node_Ptr);
+
+ procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr);
+ -- Attach a subpool node to a pool
+
+ -----------------------------------
+ -- Adjust_Controlled_Dereference --
+ -----------------------------------
+
+ procedure Adjust_Controlled_Dereference
+ (Addr : in out System.Address;
+ Storage_Size : in out System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count)
+ is
+ Header_And_Padding : constant Storage_Offset :=
+ Header_Size_With_Padding (Alignment);
+ begin
+ -- Expose the two hidden pointers by shifting the address from the
+ -- start of the object to the FM_Node equivalent of the pointers.
+
+ Addr := Addr - Header_And_Padding;
+
+ -- Update the size of the object to include the two pointers
+
+ Storage_Size := Storage_Size + Header_And_Padding;
+ end Adjust_Controlled_Dereference;
+
+ --------------
+ -- 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
+ -- 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;
+ Context_Master : Finalization_Masters.Finalization_Master_Ptr;
+ Fin_Address : Finalization_Masters.Finalize_Address_Ptr;
+ Addr : out System.Address;
+ Storage_Size : System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count;
+ Is_Controlled : Boolean;
+ On_Subpool : Boolean)
+ is
+ Is_Subpool_Allocation : constant Boolean :=
+ Pool in Root_Storage_Pool_With_Subpools'Class;
+
+ Master : Finalization_Master_Ptr := null;
+ N_Addr : Address;
+ N_Ptr : FM_Node_Ptr;
+ N_Size : Storage_Count;
+ Subpool : Subpool_Handle := null;
+
+ Allocation_Locked : Boolean;
+ -- This flag stores the state of the associated collection
+
+ Header_And_Padding : Storage_Offset;
+ -- This offset includes the size of a FM_Node plus any additional
+ -- padding due to a larger alignment.
+
+ begin
+ -- Step 1: Pool-related runtime checks
+
+ -- Allocation on a pool_with_subpools. In this scenario there is a
+ -- master for each subpool. The master of the access type is ignored.
+
+ 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));
+
+ -- Allocation with a Subpool_Handle
+
+ else
+ Subpool := Context_Subpool;
+ end if;
+
+ -- Ensure proper ownership and chaining of the subpool
+
+ if Subpool.Owner /=
+ Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
+ or else Subpool.Node = null
+ or else Subpool.Node.Prev = null
+ or else Subpool.Node.Next = null
+ then
+ raise Program_Error with "incorrect owner of subpool";
+ end if;
+
+ Master := Subpool.Master'Unchecked_Access;
+
+ -- 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";
+
+ -- If the allocation is intended to be on a subpool, but the access
+ -- type's pool does not support subpools, then this is the result of
+ -- erroneous end-user code.
+
+ elsif On_Subpool then
+ raise Program_Error
+ with "pool of access type does not support subpools";
+ end if;
+
+ Master := Context_Master;
+ end if;
+
+ -- Step 2: Master, Finalize_Address-related runtime checks and size
+ -- calculations.
+
+ -- Allocation of a descendant from [Limited_]Controlled, a class-wide
+ -- object or a record with controlled components.
+
+ if Is_Controlled then
+
+ -- Synchronization:
+ -- Read - allocation, finalization
+ -- Write - finalization
+
+ Lock_Task.all;
+ Allocation_Locked := Finalization_Started (Master.all);
+ Unlock_Task.all;
+
+ -- Do not allow the allocation of controlled objects while the
+ -- associated master is being finalized.
+
+ if Allocation_Locked then
+ raise Program_Error with "allocation after finalization started";
+ end if;
+
+ -- Check whether primitive Finalize_Address is available. If it is
+ -- not, then either the expansion of the designated type failed or
+ -- the expansion of the allocator failed. This is a serious error.
+
+ if Fin_Address = null then
+ raise Program_Error
+ with "primitive Finalize_Address not available";
+ end if;
+
+ -- The size must acount for the hidden header preceding the object.
+ -- Account for possible padding space before the header due to a
+ -- larger alignment.
+
+ Header_And_Padding := Header_Size_With_Padding (Alignment);
+
+ N_Size := Storage_Size + Header_And_Padding;
+
+ -- 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
+ Lock_Task.all;
+
+ -- Map the allocated memory into a FM_Node record. This converts the
+ -- top of the allocated bits into a list header. If there is padding
+ -- due to larger alignment, the header is placed right next to the
+ -- object:
+
+ -- N_Addr N_Ptr
+ -- | |
+ -- V V
+ -- +-------+---------------+----------------------+
+ -- |Padding| Header | Object |
+ -- +-------+---------------+----------------------+
+ -- ^ ^ ^
+ -- | +- Header_Size -+
+ -- | |
+ -- +- Header_And_Padding --+
+
+ N_Ptr := Address_To_FM_Node_Ptr
+ (N_Addr + Header_And_Padding - Header_Offset);
+
+ -- Prepend the allocated object to the finalization master
+
+ -- Synchronization:
+ -- Write - allocation, deallocation, finalization
+
+ Attach_Unprotected (N_Ptr, Objects (Master.all));
+
+ -- 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_And_Padding;
+
+ -- Homogeneous masters service the following:
+
+ -- 1) Allocations on / Deallocations from regular pools
+ -- 2) Named access types
+ -- 3) Most cases of anonymous access types usage
+
+ -- Synchronization:
+ -- Read - allocation, finalization
+ -- Write - outside
+
+ if Master.Is_Homogeneous then
+
+ -- Synchronization:
+ -- Read - finalization
+ -- Write - allocation, outside
+
+ Set_Finalize_Address_Unprotected (Master.all, Fin_Address);
+
+ -- Heterogeneous masters service the following:
+
+ -- 1) Allocations on / Deallocations from subpools
+ -- 2) Certain cases of anonymous access types usage
+
+ else
+ -- Synchronization:
+ -- Read - finalization
+ -- Write - allocation, deallocation
+
+ Set_Heterogeneous_Finalize_Address_Unprotected (Addr, Fin_Address);
+ Finalize_Address_Table_In_Use := True;
+ end if;
+
+ Unlock_Task.all;
+
+ -- Non-controlled allocation
+
+ 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
+ -- Ensure that the node has not been attached already
+
+ pragma Assert (N.Prev = null and then N.Next = null);
+
+ Lock_Task.all;
+
+ L.Next.Prev := N;
+ 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)
+ is
+ N_Addr : Address;
+ N_Ptr : FM_Node_Ptr;
+ N_Size : Storage_Count;
+
+ Header_And_Padding : Storage_Offset;
+ -- This offset includes the size of a FM_Node plus any additional
+ -- padding due to a larger alignment.
+
+ begin
+ -- Step 1: Detachment
+
+ if Is_Controlled then
+ Lock_Task.all;
+
+ -- Destroy the relation pair object - Finalize_Address since it is no
+ -- longer needed.
+
+ if Finalize_Address_Table_In_Use then
+
+ -- Synchronization:
+ -- Read - finalization
+ -- Write - allocation, deallocation
+
+ Delete_Finalize_Address_Unprotected (Addr);
+ end if;
+
+ -- Account for possible padding space before the header due to a
+ -- larger alignment.
+
+ Header_And_Padding := Header_Size_With_Padding (Alignment);
+
+ -- N_Addr N_Ptr Addr (from input)
+ -- | | |
+ -- V V V
+ -- +-------+---------------+----------------------+
+ -- |Padding| Header | Object |
+ -- +-------+---------------+----------------------+
+ -- ^ ^ ^
+ -- | +- Header_Size -+
+ -- | |
+ -- +- Header_And_Padding --+
+
+ -- Convert the bits preceding the object into a list header
+
+ N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Offset);
+
+ -- Detach the object from the related finalization master. This
+ -- action does not need to know the prior context used during
+ -- allocation.
+
+ -- Synchronization:
+ -- Write - allocation, deallocation, finalization
+
+ Detach_Unprotected (N_Ptr);
+
+ -- Move the address from the object to the beginning of the list
+ -- header.
+
+ N_Addr := Addr - Header_And_Padding;
+
+ -- The size of the deallocated object must include the size of the
+ -- hidden list header.
+
+ N_Size := Storage_Size + Header_And_Padding;
+
+ Unlock_Task.all;
+
+ 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;
+
+ ------------------------------
+ -- Default_Subpool_For_Pool --
+ ------------------------------
+
+ function Default_Subpool_For_Pool
+ (Pool : Root_Storage_Pool_With_Subpools) return not null Subpool_Handle
+ is
+ begin
+ raise Program_Error;
+ return Pool.Subpools.Subpool;
+ end Default_Subpool_For_Pool;
+
+ ------------
+ -- Detach --
+ ------------
+
+ procedure Detach (N : not null SP_Node_Ptr) is
+ begin
+ -- Ensure that the node is 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;
+ N.Prev := null;
+ N.Next := null;
+
+ 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 (Controller : in out Pool_Controller) is
+ begin
+ Finalize_Pool (Controller.Enclosing_Pool.all);
+ end Finalize;
+
+ -------------------
+ -- Finalize_Pool --
+ -------------------
+
+ procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
+ Curr_Ptr : SP_Node_Ptr;
+ Ex_Occur : Exception_Occurrence;
+ Raised : Boolean := False;
+
+ function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean;
+ -- Determine whether a list contains only one element, the dummy head
+
+ -------------------
+ -- Is_Empty_List --
+ -------------------
+
+ function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean is
+ begin
+ return L.Next = L and then L.Prev = L;
+ end Is_Empty_List;
+
+ -- Start of processing for Finalize_Pool
+
+ begin
+ -- 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;
+
+ while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop
+ Curr_Ptr := Pool.Subpools.Next;
+
+ -- Perform the following actions:
+
+ -- 1) Finalize all objects chained on the subpool's master
+ -- 2) Remove the the subpool from the owner's list of subpools
+ -- 3) Deallocate the doubly linked list node associated with the
+ -- subpool.
+ -- 4) Call Deallocate_Subpool
+
+ begin
+ Finalize_And_Deallocate (Curr_Ptr.Subpool);
+
+ exception
+ when Fin_Occur : others =>
+ if not Raised then
+ Raised := True;
+ Save_Occurrence (Ex_Occur, Fin_Occur);
+ end if;
+ end;
+ 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_Pool;
+
+ ------------------------------
+ -- Header_Size_With_Padding --
+ ------------------------------
+
+ function Header_Size_With_Padding
+ (Alignment : System.Storage_Elements.Storage_Count)
+ return System.Storage_Elements.Storage_Count
+ is
+ Size : constant Storage_Count := Header_Size;
+
+ begin
+ if Size mod Alignment = 0 then
+ return Size;
+
+ -- Add enough padding to reach the nearest multiple of the alignment
+ -- rounding up.
+
+ else
+ return ((Size + Alignment - 1) / Alignment) * Alignment;
+ end if;
+ end Header_Size_With_Padding;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ overriding procedure Initialize (Controller : in out Pool_Controller) is
+ begin
+ Initialize_Pool (Controller.Enclosing_Pool.all);
+ end Initialize;
+
+ ---------------------
+ -- Initialize_Pool --
+ ---------------------
+
+ procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
+ begin
+ -- The dummy head must point to itself in both directions
+
+ Pool.Subpools.Next := Pool.Subpools'Unchecked_Access;
+ Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
+ end Initialize_Pool;
+
+ ---------------------
+ -- Pool_Of_Subpool --
+ ---------------------
+
+ 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;
+
+ ----------------
+ -- Print_Pool --
+ ----------------
+
+ procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is
+ Head : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access;
+ Head_Seen : Boolean := False;
+ SP_Ptr : SP_Node_Ptr;
+
+ begin
+ -- Output the contents of the pool
+
+ -- Pool : 0x123456789
+ -- Subpools : 0x123456789
+ -- Fin_Start : TRUE <or> FALSE
+ -- Controller: OK <or> NOK
+
+ Put ("Pool : ");
+ Put_Line (Address_Image (Pool'Address));
+
+ Put ("Subpools : ");
+ Put_Line (Address_Image (Pool.Subpools'Address));
+
+ Put ("Fin_Start : ");
+ Put_Line (Pool.Finalization_Started'Img);
+
+ Put ("Controlled: ");
+ if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then
+ Put_Line ("OK");
+ else
+ Put_Line ("NOK (ERROR)");
+ end if;
+
+ SP_Ptr := Head;
+ while SP_Ptr /= null loop -- Should never be null
+ Put_Line ("V");
+
+ -- We see the head initially; we want to exit when we see the head a
+ -- second time.
+
+ if SP_Ptr = Head then
+ exit when Head_Seen;
+
+ Head_Seen := True;
+ end if;
+
+ -- The current element is null. This should never happend since the
+ -- list is circular.
+
+ if SP_Ptr.Prev = null then
+ Put_Line ("null (ERROR)");
+
+ -- The current element points back to the correct element
+
+ elsif SP_Ptr.Prev.Next = SP_Ptr then
+ Put_Line ("^");
+
+ -- The current element points to an erroneous element
+
+ else
+ Put_Line ("? (ERROR)");
+ end if;
+
+ -- Output the contents of the node
+
+ Put ("|Header: ");
+ Put (Address_Image (SP_Ptr.all'Address));
+ if SP_Ptr = Head then
+ Put_Line (" (dummy head)");
+ else
+ Put_Line ("");
+ end if;
+
+ Put ("| Prev: ");
+
+ if SP_Ptr.Prev = null then
+ Put_Line ("null");
+ else
+ Put_Line (Address_Image (SP_Ptr.Prev.all'Address));
+ end if;
+
+ Put ("| Next: ");
+
+ if SP_Ptr.Next = null then
+ Put_Line ("null");
+ else
+ Put_Line (Address_Image (SP_Ptr.Next.all'Address));
+ end if;
+
+ Put ("| Subp: ");
+
+ if SP_Ptr.Subpool = null then
+ Put_Line ("null");
+ else
+ Put_Line (Address_Image (SP_Ptr.Subpool.all'Address));
+ end if;
+
+ SP_Ptr := SP_Ptr.Next;
+ end loop;
+ end Print_Pool;
+
+ -------------------
+ -- Print_Subpool --
+ -------------------
+
+ procedure Print_Subpool (Subpool : Subpool_Handle) is
+ begin
+ if Subpool = null then
+ Put_Line ("null");
+ return;
+ end if;
+
+ -- Output the contents of a subpool
+
+ -- Owner : 0x123456789
+ -- Master: 0x123456789
+ -- Node : 0x123456789
+
+ Put ("Owner : ");
+ if Subpool.Owner = null then
+ Put_Line ("null");
+ else
+ Put_Line (Address_Image (Subpool.Owner'Address));
+ end if;
+
+ Put ("Master: ");
+ Put_Line (Address_Image (Subpool.Master'Address));
+
+ Put ("Node : ");
+ if Subpool.Node = null then
+ Put ("null");
+
+ if Subpool.Owner = null then
+ Put_Line (" OK");
+ else
+ Put_Line (" (ERROR)");
+ end if;
+ else
+ Put_Line (Address_Image (Subpool.Node'Address));
+ end if;
+
+ Print_Master (Subpool.Master);
+ end Print_Subpool;
+
+ -------------------------
+ -- Set_Pool_Of_Subpool --
+ -------------------------
+
+ procedure Set_Pool_Of_Subpool
+ (Subpool : not null Subpool_Handle;
+ To : in out Root_Storage_Pool_With_Subpools'Class)
+ is
+ N_Ptr : SP_Node_Ptr;
+
+ begin
+ -- 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 To.Finalization_Started then
+ raise Program_Error
+ with "subpool creation after finalization started";
+ end if;
+
+ Subpool.Owner := To'Unchecked_Access;
+
+ -- Create a subpool node and decorate it. Since this node is not
+ -- allocated on the owner's pool, it must be explicitly destroyed by
+ -- Finalize_And_Detach.
+
+ N_Ptr := new SP_Node;
+ N_Ptr.Subpool := Subpool;
+ Subpool.Node := N_Ptr;
+
+ Attach (N_Ptr, To.Subpools'Unchecked_Access);
+
+ -- Mark the subpool's master as being a heterogeneous collection of
+ -- controlled objects.
+
+ Set_Is_Heterogeneous (Subpool.Master);
+ end Set_Pool_Of_Subpool;
+
+end System.Storage_Pools.Subpools;