Ada Conformity Assessment Authority      Home Conformity Assessment   Test Suite ARGAda Standard
 
Annotated Ada Reference Manual (Ada 202x Draft 26)Legal Information
Contents   Index   References   Search   Previous   Next 

13.11.6 Storage Subpool Example

Examples

1/3
{AI05-0111-3} The following example is a simple but complete implementation of the classic Mark/Release pool using subpools:
2/3
with System.Storage_Pools.Subpools;
with System.Storage_Elements;
with Ada.Unchecked_Deallocate_Subpool;
package MR_Pool is
3/3
   use System.Storage_Pools;
      -- For uses of Subpools.
   use System.Storage_Elements;
      -- For uses of Storage_Count and Storage_Array.
4/3
   -- Mark and Release work in a stack fashion, and allocations are not allowed
   -- from a subpool other than the one at the top of the stack. This is also
   -- the default pool.
5/3
   subtype Subpool_Handle is Subpools.Subpool_Handle;
6/3
   type Mark_Release_Pool_Type (Pool_Size : Storage_Count) is new
      Subpools.Root_Storage_Pool_With_Subpools with private;
7/3
   function Mark (Pool : in out Mark_Release_Pool_Type)
      return not null Subpool_Handle;
8/3
   procedure Release (Subpool : in out Subpool_Handle) renames
      Ada.Unchecked_Deallocate_Subpool;
9/3
private
10/3
   type MR_Subpool is new Subpools.Root_Subpool with record
      Start : Storage_Count;
   end record;
   subtype Subpool_Indexes is Positive range 1 .. 10;
   type Subpool_Array is array (Subpool_Indexes) of aliased MR_Subpool;
11/4
{AI05-0298-1} {AI12-0134-1}    type Mark_Release_Pool_Type (Pool_Size : Storage_Count) is new
      Subpools.Root_Storage_Pool_With_Subpools with record
      Storage         : Storage_Array (0 .. Pool_Size-1);
      Next_Allocation : Storage_Count := 0;
      Markers         : Subpool_Array;
      Current_Pool    : Subpool_Indexes := 1;
   end record;
12/3
{AI05-0298-1}    overriding
   function Create_Subpool (Pool : in out Mark_Release_Pool_Type)
      return not null Subpool_Handle;
13/3
   function Mark (Pool : in out Mark_Release_Pool_Type)
      return not null Subpool_Handle renames Create_Subpool;
14/3
   overriding
   procedure Allocate_From_Subpool (
      Pool : in out Mark_Release_Pool_Type;
      Storage_Address : out System.Address;
      Size_In_Storage_Elements : in Storage_Count;
      Alignment : in Storage_Count;
      Subpool : not null Subpool_Handle);
15/3
   overriding
   procedure Deallocate_Subpool (
      Pool : in out Mark_Release_Pool_Type;
      Subpool : in out Subpool_Handle);
16/3
{AI05-0298-1}    overriding
   function Default_Subpool_for_Pool (Pool : in out Mark_Release_Pool_Type)
      return not null Subpool_Handle;
17/3
   overriding
   procedure Initialize (Pool : in out Mark_Release_Pool_Type);
18/3
   -- We don't need Finalize.
19/3
end MR_Pool;
20/3
package body MR_Pool is
21/3
{AI05-0298-1}    use type Subpool_Handle;
22/3
{AI05-0298-1}    procedure Initialize (Pool : in out Mark_Release_Pool_Type) is
      -- Initialize the first default subpool.
   begin
      Pool.Markers(1).Start := 1;
      Subpools.Set_Pool_of_Subpool
         (Pool.Markers(1)'Unchecked_Access, Pool);
   end Initialize;
23/3
   function Create_Subpool (Pool : in out Mark_Release_Pool_Type)
      return not null Subpool_Handle is
      -- Mark the current allocation location.
   begin
      if Pool.Current_Pool = Subpool_Indexes'Last then
         raise Storage_Error; -- No more subpools.
      end if;
      Pool.Current_Pool := Pool.Current_Pool + 1; -- Move to the next subpool
24/3
{AI05-0298-1}       return Result : constant not null Subpool_Handle :=
         Pool.Markers(Pool.Current_Pool)'Unchecked_Access
      do
         Pool.Markers(Pool.Current_Pool).Start := Pool.Next_Allocation;
         Subpools.Set_Pool_of_Subpool (Result, Pool);
      end return;
   end Create_Subpool;
25/3
{AI05-0298-1}    procedure Deallocate_Subpool (
      Pool : in out Mark_Release_Pool_Type;
      Subpool : in out Subpool_Handle) is
   begin
      if Subpool /= Pool.Markers(Pool.Current_Pool)'Unchecked_Access then
         raise Program_Error; -- Only the last marked subpool can be released.
      end if;
      if Pool.Current_Pool /= 1 then
         Pool.Next_Allocation := Pool.Markers(Pool.Current_Pool).Start;
         Pool.Current_Pool := Pool.Current_Pool - 1; -- Move to the previous subpool
      else -- Reinitialize the default subpool:
         Pool.Next_Allocation := 1;
         Subpools.Set_Pool_of_Subpool
            (Pool.Markers(1)'Unchecked_Access, Pool);
      end if;
   end Deallocate_Subpool;
26/3
{AI05-0298-1}    function Default_Subpool_for_Pool (Pool : in out Mark_Release_Pool_Type)
      return not null Subpool_Handle is
   begin
      return Pool.Markers(Pool.Current_Pool)'Unchecked_Access;
   end Default_Subpool_for_Pool;
27/3
   procedure Allocate_From_Subpool (
      Pool : in out Mark_Release_Pool_Type;
      Storage_Address : out System.Address;
      Size_In_Storage_Elements : in Storage_Count;
      Alignment : in Storage_Count;
      Subpool : not null Subpool_Handle) is
   begin
      if Subpool /= Pool.Markers(Pool.Current_Pool)'Unchecked_Access then
         raise Program_Error; -- Only the last marked subpool can be used for allocations.
      end if;
28/4
{AI12-0080-1}       -- Check for the maximum supported alignment, which is the alignment of the storage area:
      if Alignment > Pool.Storage'Alignment then
         raise Program_Error;
      end if;
      -- Correct the alignment if necessary:
      Pool.Next_Allocation := Pool.Next_Allocation +
         ((-Pool.Next_Allocation) mod Alignment);
      if Pool.Next_Allocation + Size_In_Storage_Elements >
         Pool.Pool_Size then
         raise Storage_Error; -- Out of space.
      end if;
      Storage_Address := Pool.Storage (Pool.Next_Allocation)'Address;
      Pool.Next_Allocation :=
         Pool.Next_Allocation + Size_In_Storage_Elements;
   end Allocate_From_Subpool;
29/3
end MR_Pool;

Wording Changes from Ada 2005

29.a/3
{AI05-0111-3} This example of subpools is new. 

Contents   Index   References   Search   Previous   Next 
Ada-Europe Ada 2005 and 2012 Editions sponsored in part by Ada-Europe