hcl/lib2/h3-pool.adb

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;