87 lines
2.1 KiB
Ada
87 lines
2.1 KiB
Ada
|
with Ada.Unchecked_Conversion;
|
||
|
|
with Ada.Unchecked_Deallocation;
|
||
|
|
|
||
|
|
package body H2.Pool is
|
||
|
|
|
||
|
|
function Allocate (Pool: in Storage_Pool_Pointer := null) return Pointer_Type is
|
||
|
|
P: Storage_Pool_Pointer;
|
||
|
|
|
||
|
|
begin
|
||
|
|
if Pool = null then
|
||
|
|
P := Storage_Pool;
|
||
|
|
else
|
||
|
|
P := Pool;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
if P = null then
|
||
|
|
return new Normal_Type;
|
||
|
|
else
|
||
|
|
declare
|
||
|
|
type Pooled_Pointer is access Normal_Type;
|
||
|
|
for Pooled_Pointer'Storage_Pool use P.all;
|
||
|
|
function To_Pointer_Type is new Ada.Unchecked_Conversion (Pooled_Pointer, Pointer_Type);
|
||
|
|
Tmp: Pooled_Pointer;
|
||
|
|
begin
|
||
|
|
Tmp := new Normal_Type;
|
||
|
|
return To_Pointer_Type (Tmp);
|
||
|
|
end;
|
||
|
|
end if;
|
||
|
|
end Allocate;
|
||
|
|
|
||
|
|
function Allocate (Source: in Normal_Type;
|
||
|
|
Pool: in Storage_Pool_Pointer := null) return Pointer_Type is
|
||
|
|
P: Storage_Pool_Pointer;
|
||
|
|
begin
|
||
|
|
if Pool = null then
|
||
|
|
P := Storage_Pool;
|
||
|
|
else
|
||
|
|
P := Pool;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
if P = null then
|
||
|
|
return new Normal_Type'(Source);
|
||
|
|
else
|
||
|
|
declare
|
||
|
|
type Pooled_Pointer is access Normal_Type;
|
||
|
|
for Pooled_Pointer'Storage_Pool use P.all;
|
||
|
|
function To_Pointer_Type is new Ada.Unchecked_Conversion (Pooled_Pointer, Pointer_Type);
|
||
|
|
Tmp: Pooled_Pointer;
|
||
|
|
begin
|
||
|
|
Tmp := new Normal_Type'(Source);
|
||
|
|
return To_Pointer_Type (Tmp);
|
||
|
|
end;
|
||
|
|
end if;
|
||
|
|
end Allocate;
|
||
|
|
|
||
|
|
procedure Deallocate (Target: in out Pointer_Type;
|
||
|
|
Pool: in Storage_Pool_Pointer := null) is
|
||
|
|
P: Storage_Pool_Pointer;
|
||
|
|
begin
|
||
|
|
if Pool = null then
|
||
|
|
P := Storage_Pool;
|
||
|
|
else
|
||
|
|
P := Pool;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
if P = null then
|
||
|
|
declare
|
||
|
|
procedure Dealloc is new Ada.Unchecked_Deallocation (Normal_Type, Pointer_Type);
|
||
|
|
begin
|
||
|
|
Dealloc (Target);
|
||
|
|
end;
|
||
|
|
else
|
||
|
|
declare
|
||
|
|
type Pooled_Pointer is access Normal_Type;
|
||
|
|
for Pooled_Pointer'Storage_Pool use P.all;
|
||
|
|
function To_Pooled_Pointer is new Ada.Unchecked_Conversion (Pointer_Type, Pooled_Pointer);
|
||
|
|
procedure Dealloc is new Ada.Unchecked_Deallocation (Normal_Type, Pooled_Pointer);
|
||
|
|
Tmp: Pooled_Pointer := To_Pooled_Pointer (Target);
|
||
|
|
begin
|
||
|
|
Dealloc (Tmp);
|
||
|
|
Target := null;
|
||
|
|
end;
|
||
|
|
end if;
|
||
|
|
end Deallocate;
|
||
|
|
|
||
|
|
end H2.Pool;
|