96 lines
2.3 KiB
Ada
96 lines
2.3 KiB
Ada
with Ada.Unchecked_Conversion;
|
|
with Ada.Unchecked_Deallocation;
|
|
|
|
package body H3.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
|
|
-- V: Pointer_Type;
|
|
-- begin
|
|
-- V := Allocate(Pool);
|
|
-- V.all := Source;
|
|
-- return V;
|
|
-- 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 H3.Pool;
|