hcl/lib/h2-pool.adb

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;