13.11.6 Пример подпула памяти

with System.Storage_Pools.Subpools;
with System.Storage_Elements;
with Ada.Unchecked_Deallocate_Subpool;
package MR_Pool is

use System.Storage_Pools;
-- Для использования подпулов.
use System.Storage_Elements;
-- Для использования Storage_Count и Storage_Array.

-- Функции "Пометить" и "Освободить" работают по принципу стека, и выделение памяти
-- не допускается из подпула, отличного от верхнего в стеке. Это также
-- является стандартным подпулом.

subtype Subpool_Handle is Subpools.Subpool_Handle;

type Mark_Release_Pool_Type (Pool_Size : Storage_Count) is new
Subpools.Root_Storage_Pool_With_Subpools with private;

function Mark (Pool : in out Mark_Release_Pool_Type)
return not null Subpool_Handle;

procedure Release (Subpool : in out Subpool_Handle) renames
Ada.Unchecked_Deallocate_Subpool;

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;

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;

overriding
function Create_Subpool (Pool : in out Mark_Release_Pool_Type)
return not null Subpool_Handle;

function Mark (Pool : in out Mark_Release_Pool_Type)
return not null Subpool_Handle renames Create_Subpool;

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);

overriding
procedure Deallocate_Subpool (
Pool : in out Mark_Release_Pool_Type;
Subpool : in out Subpool_Handle);

overriding
function Default_Subpool_for_Pool (Pool : in out Mark_Release_Pool_Type)
return not null Subpool_Handle;

overriding
procedure Initialize (Pool : in out Mark_Release_Pool_Type);

-- Нам не нужна Finalize.

end MR_Pool;

package body MR_Pool is

use type Subpool_Handle;

procedure Initialize (Pool : in out Mark_Release_Pool_Type) is
-- Инициализировать первый стандартный подпул.
begin
Pool.Markers(1).Start := 1;
Subpools.Set_Pool_of_Subpool
(Pool.Markers(1)'Unchecked_Access, Pool);
end Initialize;

function Create_Subpool (Pool : in out Mark_Release_Pool_Type)
return not null Subpool_Handle is
-- Пометить текущее место выделения памяти.
begin
if Pool.Current_Pool = Subpool_Indexes'Last then
raise Storage_Error; -- Больше подпулов нет.
end if;
Pool.Current_Pool := Pool.Current_Pool + 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;

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; -- Можно освободить только последний помеченный подпул.
end if;
if Pool.Current_Pool /= 1 then
Pool.Next_Allocation := Pool.Markers(Pool.Current_Pool).Start;
Pool.Current_Pool := Pool.Current_Pool - 1; -- Перейти к предыдущему подпулу
else -- Сбросить стандартный подпул:
Pool.Next_Allocation := 1;
Subpools.Set_Pool_of_Subpool
(Pool.Markers(1)'Unchecked_Access, Pool);
end if;
end Deallocate_Subpool;

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;

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; -- Для выделения памяти можно использовать только последний помеченный подпул.
end if;

-- Проверка максимального поддерживаемого выравнивания, которое соответствует выравниванию области памяти:
if Alignment > Pool.Storage'Alignment then
raise Program_Error;
end if;
-- Корректировка выравнивания при необходимости:
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; -- Недостаточно памяти.
end if;
Storage_Address := Pool.Storage (Pool.Next_Allocation)'Address;
Pool.Next_Allocation :=
Pool.Next_Allocation + Size_In_Storage_Elements;
end Allocate_From_Subpool;

end MR_Pool;