------------------------------------------------------------------------------
--                                                                          --
--                         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-2026, 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.Finalization;
with System.Finalization_Primitives;
with System.Storage_Elements;

package System.Storage_Pools.Subpools is
   pragma Preelaborate;

   type Root_Storage_Pool_With_Subpools is abstract
     new Root_Storage_Pool with private
   with
     Preelaborable_Initialization;
   --  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
   with
     Preelaborable_Initialization;
   --  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. Controlled types allocated through this
   --  routine will NOT be handled properly.

   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)
      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 : in out Root_Storage_Pool_With_Subpools)
      return not null Subpool_Handle;
   --  Return a common subpool which is used for object allocations without a
   --  Subpool_Handle_Name in the allocator. The default implementation of this
   --  routine raises Program_Error.

   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;
      To      : 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.

   overriding function Storage_Size
     (Pool : Root_Storage_Pool_With_Subpools)
      return System.Storage_Elements.Storage_Count
   is
      (System.Storage_Elements.Storage_Count'Last);

   procedure _Adjust_Clone (Subpool : in out Root_Subpool);
   --  After copying the value of an initialized (but otherwise unused)
   --  Root_Subpool object into another subpool object using unchecked
   --  techniques (an assignment statement would be illegal), this
   --  procedure is called to fixup the copy (in particular, it fixes up
   --  self-referential access values contained therein).
   --
   --  The leading underscore is intentional. We don't want a user-visible
   --  declaration that is not mentioned in the spec for this package that
   --  is given in the Ada RM. This subprogram is called only from the body
   --  of Ada.Containers.Bounded_Indefinite_Holders.

private
   --  SP_Nodes are created on the heap, while collection nodes and associated
   --  objects are created on the pool_with_subpools.

   type Any_Storage_Pool_With_Subpools_Ptr
     is access all Root_Storage_Pool_With_Subpools'Class;
   for Any_Storage_Pool_With_Subpools_Ptr'Storage_Size use 0;

   --  A pool controller is a special controlled object which ensures the
   --  proper initialization and finalization of the enclosing pool.

   type Pool_Controller (Enclosing_Pool : Any_Storage_Pool_With_Subpools_Ptr)
     is new Ada.Finalization.Limited_Controlled with null record;

   --  Subpool list types. Each pool_with_subpools contains a list of subpools.
   --  This is an indirect doubly linked list since subpools are not supposed
   --  to be allocatable by language design.

   type SP_Node;
   type SP_Node_Ptr is access all SP_Node;

   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. The type uses a
   --  special controller to perform initialization and finalization actions
   --  on itself. This is necessary because the end user of this package may
   --  decide to override Initialize and Finalize, thus disabling the desired
   --  behavior.

   --          Pool_With_Subpools     SP_Node    SP_Node    SP_Node
   --    +-->+--------------------+   +-----+    +-----+    +-----+
   --    |   |      Subpools -------->|  ------->|  ------->|  ------->
   --    |   +--------------------+   +-----+    +-----+    +-----+
   --    |   |Finalization_Started|   :     :    :     :    :     :
   --    |   +--------------------+
   --    +--- Controller.Encl_Pool|
   --        +--------------------+
   --        :       End-user     :
   --        :      components    :

   type Root_Storage_Pool_With_Subpools is abstract
     new Root_Storage_Pool with
   record
      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 parent
      --  pool is being finalized. The flag needs to be atomic because it is
      --  accessed without Lock_Task / Unlock_Task.

      Controller : Pool_Controller
                     (Root_Storage_Pool_With_Subpools'Unchecked_Access);
      --  A component which ensures that the enclosing pool is initialized and
      --  finalized at the appropriate places.
   end record;

   --  A subpool is an abstraction layer which sits on top of a pool. It
   --  contains links to all controlled objects allocated on a particular
   --  subpool.

   --             Pool_With_Subpools     SP_Node    SP_Node    SP_Node
   --       +-->+--------------------+   +-----+    +-----+    +-----+
   --       |   |      Subpools -------->|  ------->|  ------->|  ------->
   --       |   +--------------------+   +-----+    +-----+    +-----+
   --       |   |Finalization_Started|<------  |<-------  |<-------  |<---
   --       |   +--------------------+   +-----+    +-----+    +-----+
   --       +--- Controller.Encl_Pool|   | nul |    |  +  |    |  +  |
   --       |   +--------------------+   +-----+    +--|--+    +--:--+
   --       |   :                    :    Dummy        |  ^       :
   --       |   :                    :                 |  |       :
   --       |                            Root_Subpool  V  |
   --       |                            +-------------+  |
   --       +-------------------------------- Owner    |  |
   --                Collection nodes    +-------------+  |
   --               +-----+   +-----+<-- | Collection  |
   --            <------  |<------  |    +-------------+  |
   --               +-----+   +-----+    |    Node -------+
   --               |  ------>|  ----->  +-------------+
   --               +-----+   +-----+    :             :
   --               |ctrl |    Dummy     :             :
   --               | obj |
   --               +-----+

   type Root_Subpool is abstract tagged limited record
      Owner : Any_Storage_Pool_With_Subpools_Ptr := null;
      --  A reference to the parent pool_with_subpools

      Collection : aliased Finalization_Primitives.Finalization_Collection;
      --  A collection of controlled objects

      Node : SP_Node_Ptr := null;
      --  A link to the doubly linked list node which contains the subpool.
      --  This back pointer is used in subpool deallocation.
   end record;

   procedure Adjust_Controlled_Dereference
     (Addr         : in out System.Address;
      Storage_Size : in out System.Storage_Elements.Storage_Count;
      Alignment    : System.Storage_Elements.Storage_Count);
   --  Given the memory attributes of a heap-allocated object that is known to
   --  be controlled, adjust the address and size of the object to include the
   --  hidden header inserted by the finalization machinery and its padding.

   --  ??? 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;
      Named_Subpool : Subpool_Handle;
      Collection    : in out
                        Finalization_Primitives.Finalization_Collection_Ptr;
      Addr          : out System.Address;
      Storage_Size  : System.Storage_Elements.Storage_Count;
      Alignment     : System.Storage_Elements.Storage_Count;
      Is_Controlled : Boolean;
      On_Subpool    : Boolean);
   --  Compiler interface. This version of Allocate handles all possible cases,
   --  either on a pool or a pool_with_subpools, regardless of the controlled
   --  status of the allocated object. Parameter usage:
   --
   --    * Pool - The pool associated with the access type. Pool can be any
   --    derivation from Root_Storage_Pool, including a pool_with_subpools.
   --
   --    * Named_Subpool - The subpool identified by the handle name of an
   --    allocator. If no handle name is present, the actual would be null.
   --
   --    * Collection - The finalization collection associated with the access
   --    type if its designated type is controlled. If it is not, the actual
   --    would be null. If the object is allocated on a subpool, the parameter
   --    is updated to the collection of the subpool.
   --
   --    * Addr - The address of the allocated object.
   --
   --    * Storage_Size - The size of the allocated object.
   --
   --    * Alignment - The alignment of the allocated object.
   --
   --    * Is_Controlled - A flag which determines whether the allocated object
   --    is controlled. When set to True, the machinery allocates more space
   --    and returns a displaced address.
   --
   --    * On_Subpool - A flag which determines whether the a subpool handle
   --    name is present at the point of allocation. This is used for error
   --    diagnostics.

   procedure Deallocate_Any_Controlled
     (Pool          : in out Root_Storage_Pool'Class;
      Addr          : System.Address;
      Storage_Size  : System.Storage_Elements.Storage_Count;
      Alignment     : System.Storage_Elements.Storage_Count;
      Is_Controlled : Boolean);
   --  Compiler interface. This version of Deallocate handles all possible
   --  cases, either from a pool or a pool_with_subpools, regardless of the
   --  controlled status of the deallocated object. Parameter usage:
   --
   --    * Pool - The pool associated with the access type. Pool can be any
   --    derivation from Root_Storage_Pool, including a pool_with_subpools.
   --
   --    * Addr - The address of the allocated object.
   --
   --    * Storage_Size - The size of the allocated object.
   --
   --    * Alignment - The alignment of the allocated object.
   --
   --    * Is_Controlled - A flag which determines whether the allocated object
   --    is controlled. When set to True, the address must be displaced.

   procedure Detach (N : not null SP_Node_Ptr);
   --  Unhook a subpool node from an arbitrary subpool list

   overriding procedure Finalize (Controller : in out Pool_Controller);
   --  Buffer routine, calls Finalize_Pool

   procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools);
   --  Iterate over all subpools of Pool, detach them one by one and finalize
   --  their collections. This action first detaches a controlled object from a
   --  particular collection, then invokes its Finalize_Address primitive.

   function Header_Size_With_Padding
     (Alignment : System.Storage_Elements.Storage_Count)
      return System.Storage_Elements.Storage_Count;
   --  Given an arbitrary alignment, calculate the size of the header which
   --  precedes a controlled object as the nearest multiple rounded up of the
   --  alignment.

   overriding procedure Initialize (Controller : in out Pool_Controller);
   --  Buffer routine, calls Initialize_Pool

   procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools);
   --  Setup the doubly linked list of subpools

   procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools);
   --  Debug routine, output the contents of a pool_with_subpools

   procedure Print_Subpool (Subpool : Subpool_Handle);
   --  Debug routine, output the contents of a subpool

end System.Storage_Pools.Subpools;
