| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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-2021, 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 successful 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; |
| Lock_Taken : Boolean := False; |
| |
| 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 compiler bug. |
| |
| pragma Assert |
| (Context_Master /= null, "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. |
| |
| if Context_Subpool /= null then |
| raise Program_Error |
| with "subpool not required in pool allocation"; |
| end if; |
| |
| -- If the allocation is intended to be on a subpool, but the access |
| -- type's pool does not support subpools, then this is the result of |
| -- incorrect end-user code. |
| |
| if On_Subpool then |
| raise Program_Error |
| with "pool of access type does not support subpools"; |
| end if; |
| |
| Master := Context_Master; |
| end if; |
| |
| -- Step 2: Master, 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_Taken := True; |
| Lock_Task.all; |
| |
| -- Do not allow the allocation of controlled objects while the |
| -- associated master is being finalized. |
| |
| if Finalization_Started (Master.all) 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 compiler bug. |
| |
| pragma Assert |
| (Fin_Address /= null, "primitive Finalize_Address not available"); |
| |
| -- The size must account 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 |
| |
| -- Note that we already did "Lock_Task.all;" in Step 2 above |
| |
| -- 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_Size); |
| |
| -- 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; |
| Lock_Taken := False; |
| |
| -- Non-controlled allocation |
| |
| else |
| Addr := N_Addr; |
| end if; |
| |
| exception |
| when others => |
| |
| -- Unlock the task in case the allocation step failed and reraise the |
| -- exception. |
| |
| if Lock_Taken then |
| Unlock_Task.all; |
| end if; |
| |
| raise; |
| 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; |
| |
| begin |
| -- 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_Size); |
| |
| -- 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; |
| |
| exception |
| when others => |
| |
| -- Unlock the task in case the computations performed above |
| -- fail for some reason. |
| |
| Unlock_Task.all; |
| raise; |
| end; |
| 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 : in out Root_Storage_Pool_With_Subpools) |
| return not null Subpool_Handle |
| is |
| pragma Unreferenced (Pool); |
| begin |
| return raise Program_Error with |
| "default Default_Subpool_For_Pool called; must be overridden"; |
| 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 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; |
