Ada Reference Manual (Ada 2022) — Legal Information

# 13.11.6 Storage Subpool Example

#### Examples

1/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
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);
Next_Allocation : Storage_Count := 0;
Markers : Subpool_Array;
Current_Pool : Subpool_Indexes := 1;
end record;
12/3
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
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
use type Subpool_Handle;
22/3
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
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
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
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
-- 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;

Ada 2005 and 2012 Editions sponsored in part by Ada-Europe