trying to rewrite h2

h2/lib2/h3-limited_pool.adb

@@ -0,0 +1,61 @@
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+
+package body H3.Limited_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;
+
+	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.Limited_Pool;

h2/lib2/h3-limited_pool.ads

@@ -0,0 +1,24 @@
+--------------------------------------------------------------------
+-- Instantantiate this package before using. To allocate integers,
+--
+--   type Integer_Pointer is access Integer_Pointer;
+--   package Integer_Pool is new Pool(Integer, Integer_Pointer, Storage_Pool'Unchecked_Access);
+--   x: Integer_Pointer;
+--
+--   x := Integer_Pool.Allocate(10);
+--------------------------------------------------------------------
+
+generic
+	type Normal_Type is limited private;
+	type Pointer_Type is access Normal_Type;
+	Storage_Pool: in Storage_Pool_Pointer := null;
+
+package H3.Limited_Pool is
+	--pragma Preelaborate (Pool);
+
+	function Allocate (Pool: in Storage_Pool_Pointer := null) return Pointer_Type;
+
+	procedure Deallocate (Target: in out Pointer_Type;
+	                      Pool:   in     Storage_Pool_Pointer := null);
+
+end H3.Limited_Pool;

h2/lib2/h3-mm.adb

@@ -0,0 +1,56 @@
+with Ada.Unchecked_Deallocation;
+
+package body H3.MM is
+	procedure Create (R: in out Ref_Counted) is
+	begin
+		Finalize (R);
+		R.Data := new Ref_Counted_Record;
+		--R.Data.Ref_Count := 1;
+		System.Atomic_Counters.Initialize (R.Data.Ref_Count); -- initialize to 1
+	end Create;
+ 
+	procedure Create (R: in out Ref_Counted; V: in Item_Type) is
+	begin
+		Create (R);
+		R.Data.Item := V;
+	end Create;
+
+	function Get_Item_Pointer (R: in out Ref_Counted) return Item_Pointer is
+	begin
+		if R.Data /= null then
+			return R.Data.Item'Access;
+		else
+			return null;
+		end if;
+	end Get_Item_Pointer;
+
+	function Is_Shared (R: in Ref_Counted) return Standard.Boolean is
+	begin
+		return R.Data /= null and then not System.Atomic_Counters.Is_One(R.Data.Ref_Count);
+	end Is_Shared;
+
+	procedure Initialize (R: in out Ref_Counted) is
+	begin
+		R.Data := null;
+	end Initialize;
+
+	procedure Adjust (R: in out Ref_Counted) is
+	begin
+		if R.Data /= null then
+			--R.Data.Ref_Count := R.Data.Ref_Count + 1;
+			System.Atomic_Counters.Increment (R.Data.Ref_Count);
+		end if;
+	end Adjust;
+
+	procedure Finalize (R: in out Ref_Counted) is
+		procedure Dealloc is new Ada.Unchecked_Deallocation(Ref_Counted_Record, Ref_Counted_Pointer);
+	begin
+		if R.Data /= null then	
+			if System.Atomic_Counters.Decrement(R.Data.Ref_Count) then
+				-- The reference count reached 0
+				Dealloc (R.Data); 
+				-- R.DAta must be null here
+			end if;
+		end if;
+	end Finalize;
+end H3.MM;

h2/lib2/h3-mm.ads

@@ -0,0 +1,35 @@
+with Ada.Finalization;
+
+generic
+	type Item_Type is private;
+--	type Pointer_Type is access Item_Type;
+package H3.MM is
+	type Item_Pointer is access all Item_Type;
+
+	type Ref_Counted_Record is record
+		Ref_Count: System.Atomic_Counters.Atomic_Counter;
+		Item: aliased Item_Type;
+	end record;
+
+	type Ref_Counted_Pointer is access Ref_Counted_Record;
+
+	type Ref_Counted is new Ada.Finalization.Controlled with record
+		Data: Ref_Counted_Pointer;
+	end record;
+
+	procedure Create (R: in out Ref_Counted);
+	procedure Create (R: in out Ref_Counted; V: in Item_Type);
+
+	function Get_Item_Pointer (R: in out Ref_Counted) return Item_Pointer;
+	pragma Inline(Get_Item_Pointer);
+
+	function Is_Shared (R: in Ref_Counted) return Standard.Boolean;
+	pragma Inline(Is_Shared);
+
+
+	overriding procedure Initialize (R: in out Ref_Counted);
+	overriding procedure Adjust (R: in out Ref_Counted);
+	overriding procedure Finalize (R: in out Ref_Counted);
+
+	
+end H3.MM;

h2/lib2/h3-pool.adb

@@ -0,0 +1,95 @@
+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;

h2/lib2/h3-pool.ads

@@ -0,0 +1,27 @@
+--------------------------------------------------------------------
+-- Instantantiate this package before using. To allocate integers,
+--
+--   type Integer_Pointer is access Integer_Pointer;
+--   package Integer_Pool is new Pool(Integer, Integer_Pointer, Storage_Pool'Unchecked_Access);
+--   x: Integer_Pointer;
+--
+--   x := Integer_Pool.Allocate(10);
+--------------------------------------------------------------------
+
+generic
+	type Normal_Type is private;
+	type Pointer_Type is access Normal_Type;
+	Storage_Pool: in Storage_Pool_Pointer := null;
+
+package H3.Pool is
+	--pragma Preelaborate (Pool);
+
+	function Allocate (Pool: in Storage_Pool_Pointer := null) return Pointer_Type;
+
+	function Allocate (Source: in Normal_Type; 
+	                   Pool:   in Storage_Pool_Pointer := null) return Pointer_Type;
+
+	procedure Deallocate (Target: in out Pointer_Type;
+	                      Pool:   in     Storage_Pool_Pointer := null);
+
+end H3.Pool;

h2/lib2/h3-storage_pools.adb

@@ -0,0 +1,75 @@
+with System;
+with System.Address_Image;
+
+with Ada.Text_IO;
+
+package body H3.Storage_Pools is
+
+	function Sys_Malloc (Size: System_Size) return System.Address;
+	pragma Import (Convention => C, Entity => Sys_Malloc, External_Name => "malloc");
+
+	procedure Sys_Free (Ptr: System.Address);
+	pragma Import (Convention => C, Entity => Sys_Free, External_Name => "free");
+
+	procedure Allocate (Pool:      in out Global_Pool;
+	                    Address :  out    System.Address;
+	                    Size:      in     SSE.Storage_Count;
+	                    Alignment: in     SSE.Storage_Count) is
+		tmp: System.Address;
+		use type SSE.Storage_Count;
+	begin
+		tmp := Sys_Malloc(System_Size(((Size + Alignment - 1) / Alignment) * Alignment));
+		if System."="(tmp, System.Null_Address) then
+			raise Storage_Error;
+		else
+			Address := tmp;
+Ada.Text_IO.Put_Line ("Global_Pool Allocating Size: " & SSE.Storage_Count'Image (Size) & " Actual-Size: " & SSE.Storage_Count'Image (((Size + Alignment - 1) / Alignment) * Alignment) & "Address: " & System.Address_Image(Address));
+		end if;
+	end Allocate;
+
+	procedure Deallocate (Pool:      in out Global_Pool;
+	                      Address :  in     System.Address;
+	                      Size:      in     SSE.Storage_Count;
+	                      Alignment: in     SSE.Storage_Count) is
+
+	begin
+--Ada.Text_IO.Put_Line ("Global_Pool Deallocating Address: " & System.Address'Img);
+Ada.Text_IO.Put_Line ("Global_Pool Deallocating " & System.Address_Image(Address));
+		Sys_Free (Address);
+	end Deallocate;
+
+	function Storage_Size (Pool: in Global_Pool) return SSE.Storage_Count is
+	begin
+Ada.Text_IO.Put_Line ("Global_Pool Storage_Size ");
+		return SSE.Storage_Count'Last;
+	end Storage_Size;
+
+
+
+	-- TODO: find a better solution
+	-- gnat 3.15p somehow looks for the rountines below when H3.Pool is used.
+	-- let me put these routines here temporarily until i find a proper solution.
+	procedure Allocate_315P (Pool:      in out SSP.Root_Storage_Pool'Class;
+	                         Address :  out    System.Address;
+	                         Size:      in     SSE.Storage_Count;
+	                         Alignment: in     SSE.Storage_Count);
+	pragma Export (Ada, Allocate_315P, "system__storage_pools__allocate");
+	procedure Allocate_315P (Pool:      in out SSP.Root_Storage_Pool'Class;
+	                         Address :  out    System.Address;
+	                         Size:      in     SSE.Storage_Count;
+	                         Alignment: in     SSE.Storage_Count) is
+	begin
+ada.text_io.put_line ("system__storage_pools__allocate...");
+		SSP.Allocate (Pool, Address, Size, Alignment);
+	end Allocate_315P;
+
+	procedure Deallocate_315P (Pool: in out SSP.Root_Storage_Pool'Class; Address : in System.Address; Size: in SSE.Storage_Count; Alignment: in SSE.Storage_Count);
+	pragma Export (Ada, Deallocate_315P, "system__storage_pools__deallocate");
+	procedure Deallocate_315P (Pool: in out SSP.Root_Storage_Pool'Class; Address : in System.Address; Size: in SSE.Storage_Count; Alignment: in SSE.Storage_Count) is
+	begin
+ada.text_io.put_line ("system__storage_pools__deallocate...");
+		SSP.Deallocate (Pool, Address, Size, Alignment);
+	end Deallocate_315P;
+
+end H3.Storage_Pools;
+

h2/lib2/h3-storage_pools.ads

@@ -0,0 +1,26 @@
+with System.Storage_Pools;
+with System.Storage_Elements;
+
+package H3.Storage_Pools is
+
+	package SSE renames System.Storage_Elements;
+	package SSP renames System.Storage_Pools;
+
+	type Global_Pool is new SSP.Root_Storage_Pool with private;
+
+	procedure Allocate (Pool:      in out Global_Pool;
+	                    Address:   out    System.Address;
+	                    Size:      in     SSE.Storage_Count;
+	                    Alignment: in     SSE.Storage_Count);
+
+	procedure Deallocate (Pool:      in out Global_Pool;
+	                      Address:   in     System.Address;
+	                      Size:      in     SSE.Storage_Count;
+	                      Alignment: in     SSE.Storage_Count);
+
+	function Storage_Size (Pool: in Global_Pool) return SSE.Storage_Count;
+
+private
+	type Global_Pool is new SSP.Root_Storage_Pool with null record;
+
+end H3.Storage_Pools;

h2/lib2/h3-strings.adb

@@ -0,0 +1,178 @@
+with Ada.Unchecked_Deallocation;
+
+with ada.text_io;
+
+package body H3.Strings is
+	BUFFER_ALIGN: constant := 16;
+
+	function To_Character_Array (Str: in Elastic_String) return Character_Array is
+	begin
+		return Str.Buffer.Slot(Str.Buffer.Slot'First .. Str.Buffer.Last);
+	end To_Character_Array;
+
+	function Get_Capacity (Str: in Elastic_String) return System_Size is
+	begin
+		return Str.Buffer.Slot'Length - 1;
+	end Get_Capacity;
+
+	function Get_Length (Str: in Elastic_String) return System_Size is
+	begin
+		return Str.Buffer.Last - Str.Buffer.Slot'First + 1;
+	end Get_Length;
+
+	function Get_Item (Str: in Elastic_String; Pos: in System_Index) return Character_Type is
+	begin
+		return Str.Buffer.Slot(Pos);
+	end Get_Item;
+
+	-- unsafe as it exposes the internal buffer which can go away.
+	-- assume the system address is equal to the thin pointer in size.
+	function Get_Slot_Pointer (Str: in Elastic_String) return Thin_Character_Array_Pointer is
+		A: System.Address := Str.Buffer.Slot(Str.Buffer.Slot'First)'Address;
+		P: Thin_Character_Array_Pointer;
+		for P'Address use A'Address;
+		pragma Import (Ada, P);
+	begin
+		return P;
+	end Get_Slot_Pointer;
+
+	function Is_Shared(Str: in Elastic_String) return Standard.Boolean is
+	begin
+		return Str.Buffer /= Empty_Buffer'Access and then Str.Buffer.Refs > 1;
+	end Is_Shared;
+
+	procedure Free_Buffer (Str: in out Elastic_String) is
+	begin
+		if Str.Buffer /= Empty_Buffer'Access then
+			declare
+				procedure Free is new Ada.Unchecked_Deallocation(Buffer_Record, Buffer_Pointer);
+			begin
+				Free (Str.Buffer);
+			end;
+		end if;
+	end Free_Buffer;
+
+	procedure Ref_Buffer (Buf: in out Buffer_Pointer) is
+	begin
+		if Buf /= Empty_Buffer'Access then
+ada.text_io.put_line ("ref_buffer -> " & Buf.Refs'Img);
+			Buf.Refs := Buf.Refs + 1;
+		end if;
+	end Ref_Buffer;
+
+	procedure Deref_Buffer (Buf: in out Buffer_Pointer) is
+	begin
+		if Buf /= Empty_Buffer'Access then
+ada.text_io.put_line ("deref_buffer -> " & Buf.Refs'Img);
+			if Buf.Refs = 1 then
+				declare
+					procedure Free is new Ada.Unchecked_Deallocation(Buffer_Record, Buffer_Pointer);
+				begin
+					Free (Buf);
+				end;
+			else
+				Buf.Refs := Buf.Refs - 1;
+			end if;
+		end if;
+	end Deref_Buffer;
+
+	procedure Prepare_Buffer (Str: in out Elastic_String) is
+		Tmp: Buffer_Pointer;
+	begin
+		if Str.Buffer /= Empty_Buffer'Access then
+			if Is_Shared(Str) then
+				Tmp := new Buffer_Record(Str.Buffer.Slot'Length);
+				Tmp.Slot := Str.Buffer.Slot;
+				Tmp.Last := Str.Buffer.Last;
+				Tmp.Refs := 1;	--Ref_Buffer (Tmp);
+				Deref_Buffer (Str.Buffer);
+				Str.Buffer := Tmp;
+			end if;
+		end if;
+	end Prepare_Buffer;
+
+	procedure Prepare_Buffer (Str: in out Elastic_String; ReqCapa: in System_Size) is
+		Tmp: Buffer_Pointer;
+	begin
+		if Str.Buffer /= Empty_Buffer'Access then
+			if Is_Shared(Str) then
+				-- ReqCapa must be greater than Str.Buffer.Slot'Length
+				Tmp := new Buffer_Record(ReqCapa);
+				Tmp.Slot(Str.Buffer.Slot'First .. Str.Buffer.Last + 1) := Str.Buffer.Slot(Str.Buffer.Slot'First .. Str.Buffer.Last + 1);
+				Tmp.Last := Str.Buffer.Last;
+				Tmp.Refs := 1; --Ref_Buffer (Tmp);
+				Deref_Buffer (Str.Buffer);
+				Str.Buffer := Tmp;
+			end if;
+		end if;
+	end Prepare_Buffer;
+
+	procedure Clear (Str: in out Elastic_String) is
+	begin
+		Prepare_Buffer (Str);
+		Str.Buffer.Last := Str.Buffer.Slot'First - 1;
+	end Clear;
+
+	procedure Purge (Str: in out Elastic_String) is
+	begin 
+		Deref_Buffer (Str.Buffer);
+		Str.Buffer := Empty_Buffer'Access;
+	end Purge;
+
+-- TODO: operator "&"
+	procedure Append (Str: in out Elastic_String; V: in Character_Array) is
+		ReqCapa: System_Size;
+		Tmp: Buffer_Pointer;
+	begin
+		if V'Length > 0 then
+			ReqCapa := H3.Align(Str.Buffer.Last + V'Length + 1, BUFFER_ALIGN);
+			Prepare_Buffer (Str, ReqCapa);
+
+			if ReqCapa > Get_Capacity(Str) then
+				Tmp := new Buffer_Record(ReqCapa);
+				Tmp.Slot(Str.Buffer.Slot'First .. Str.Buffer.Last) := Str.Buffer.Slot(Str.Buffer.Slot'First .. Str.Buffer.Last);
+				Tmp.Last := Str.Buffer.Last;
+				Free_Buffer (Str);
+				Str.Buffer := Tmp;
+			end if;
+
+			Str.Buffer.Slot(Str.Buffer.Last + 1 .. Str.Buffer.Last + V'Length) := V;
+			Str.Buffer.Last := Str.Buffer.Last + V'Length;
+			Str.Buffer.Slot(Str.Buffer.Last + 1) := Null_Character;
+		end if;
+	end Append;
+
+	procedure Append (Str: in out Elastic_String; V: in Character_Type) is
+		Tmp: Character_Array(1 .. 1) := (1 => V);
+	begin
+		Append (Str, Tmp);
+	end Append;
+
+	procedure Delete (Str: in out Elastic_String; Pos: in System_Index; Length: in System_Length) is
+	begin
+		null;
+	end Delete;
+
+
+
+	-- ---------------------------------------------------------------------
+	-- Controlled Management
+	-- ---------------------------------------------------------------------
+	procedure Initialize (Str: in out Elastic_String) is
+	begin
+ada.text_io.put_line("ES Initialize");
+		null;
+	end Initialize;
+
+	procedure Adjust (Str: in out Elastic_String) is
+	begin
+ada.text_io.put_line("ES Adhust");
+		Ref_Buffer (Str.Buffer);
+	end Adjust;
+
+	procedure Finalize (Str: in out Elastic_String) is
+	begin
+ada.text_io.put_line("ES Finalize");
+		Deref_Buffer (Str.Buffer);
+	end Finalize;
+end H3.Strings;

h2/lib2/h3-strings.ads

@@ -0,0 +1,61 @@
+with Ada.Finalization;
+
+generic
+	--type Character_Type is private;
+	type Character_Type is (<>);
+	Null_Character: Character_Type;
+package H3.Strings is
+
+	type Elastic_String is private;
+	type Character_Array is array(System_Index range <>) of Character_Type;
+	--type Character_Array_Pointer is access all Character_Array;
+
+	subtype Thin_Character_Array is Character_Array(System_Index'Range);
+	type Thin_Character_Array_Pointer is access Thin_Character_Array;
+
+	function To_Character_Array (Str: in Elastic_String) return Character_Array;
+
+	function Get_Capacity (Str: in Elastic_String) return System_Size;
+	pragma Inline (Get_Capacity);
+
+	function Get_Length (Str: in Elastic_String) return System_Size;
+	pragma Inline (Get_Length);
+
+	function Get_Item (Str: in Elastic_String; Pos: in System_Index) return Character_Type;
+	pragma Inline (Get_Item);
+
+	function Get_Slot_Pointer (Str: in Elastic_String) return Thin_Character_Array_Pointer;
+	pragma Inline (Get_Slot_Pointer);
+
+	function Is_Shared(Str: in Elastic_String) return Standard.Boolean;
+
+	procedure Clear (Str: in out Elastic_String);
+	procedure Purge (Str: in out Elastic_String);
+
+	procedure Append (Str: in out Elastic_String; V: in Character_Array);
+	procedure Append (Str: in out Elastic_String; V: in Character_Type);
+
+private
+	
+	type Buffer_Record(Size: System_Size) is limited record
+		Refs: System_Size := 0;
+		Slot: Character_Array(1 .. Size);
+		Last: System_Size := 0;
+	end record;
+
+	type Buffer_Pointer is access all Buffer_Record;
+
+	--Empty_Buffer: aliased Buffer_Record(1);
+	Empty_Buffer: aliased Buffer_Record := (Size => 1, Refs => 0, Slot => (1 => Null_Character), Last => 0);
+
+	type Elastic_String is new Ada.Finalization.Controlled with record
+		Buffer: Buffer_Pointer := Empty_Buffer'Access;
+	end record;
+
+	overriding procedure Initialize (Str: in out Elastic_String);
+	overriding procedure Adjust     (Str: in out Elastic_String);
+	overriding procedure Finalize   (Str: in out Elastic_String);
+
+
+
+end H3.Strings;

h2/lib2/h3.adb

@@ -0,0 +1,43 @@
+
+package body H3 is
+
+	function Align (X: in System_Size; Y: in System_Size) return System_Size is
+	begin
+		return ((X + Y - 1) / Y) * Y;
+	end Align;
+
+
+
+--	procedure Set (R: in out Ref; Data: in Ref_Counted_Pointer) is
+--	begin
+--		if R.Data /= null then
+--			Finalize (R);
+--		end if;
+--
+--		R.Data := Data;
+--		Adjust (R);
+--	end Set;
+
+--	function Get (R: in Ref) return Ref_Counted_Pointer is
+--	begin
+--		return R.Data;
+--	end Get;
+
+--	procedure Adjust (R: in out Ref) is
+--	begin
+--		if R.Data /= null then
+--			R.Data.Ref_Count := R.Data.Ref_Count + 1;
+--		end if;
+--	end Adjust;
+
+--	procedure Finalize (R: in out Ref) is
+--	begin
+--		if R.Data /= null then
+--			R.Data.Ref_Count  := R.Data.Ref_Count - 1;
+--			if R.Data.Ref_Count = 0 then
+--				null;
+--			end if;
+--			R.Data := null;
+--		end if;
+--	end Finalize;
+end H3;

h2/lib2/h3.ads

@@ -0,0 +1,56 @@
+with System;
+with System.Storage_Pools;
+with System.Atomic_Counters;
+with Ada.Finalization;
+
+package H3 is
+	--pragma Preelaborate (H2);
+	System_Byte_Bits: constant := System.Storage_Unit;
+	System_Word_Bits: constant := System.Word_Size;
+	System_Word_Bytes: constant := System_Word_Bits / System_Byte_Bits;
+
+	type System_Byte is mod 2 ** System_Byte_Bits;
+	for System_Byte'Size use System_Byte_Bits;
+
+	type System_Word is mod 2 ** System_Word_Bits;
+	for System_Word'Size use System_Word_Bits;
+
+	type System_Signed_Word is range -(2 ** (System_Word_Bits - 1)) ..
+	                                 +(2 ** (System_Word_Bits - 1)) - 1;
+	for System_Signed_Word'Size use System_Word_Bits;
+
+	--type System_Size is new System_Word range 0 .. (2 ** System_Word_Bits) - 1;
+	subtype System_Size is System_Word range 0 .. (2 ** System_Word_Bits) - 1;
+	subtype System_Length is System_Size;
+
+	--subtype System_Index is System_Size range 0 .. (System_Size'Last - 1);
+	subtype System_Index is System_Size range 1 .. System_Size'Last;
+
+	type Storage_Pool_Pointer is access all System.Storage_Pools.Root_Storage_Pool'Class;
+
+	type System_Byte_Array is array(System_Index range<>) of System_Byte;
+
+	-- ---------------------------------------------------------------------
+	-- Utilities Functions
+	-- ---------------------------------------------------------------------
+	function Align (X: in System_Size; Y: in System_Size) return System_Size;
+	pragma Inline(Align);
+
+	-- ---------------------------------------------------------------------
+	-- Reference Counting
+	-- ---------------------------------------------------------------------
+--	type Ref_Counted is abstract tagged record
+--		--Ref_Count: System.Atomic_Counters.Atomic_Counter;
+--		Ref_Count: System_Size;
+--	end record;
+
+--	type Ref_Counted_Pointer is access all Ref_Counted'Class;
+--	type Ref is new Ada.Finalization.Controlled with record
+--		Data: Ref_Counted_Pointer;
+--	end record;
+
+--	procedure Set (R: in out Ref; Data: in Ref_Counted_Pointer);
+--	function Get (R: in Ref) return Ref_Counted_Pointer;
+--	overriding procedure Adjust (R: in out Ref);
+--	overriding procedure Finalize (R: in out Ref);
+end H3;

h2/lib2/hello.adb

@@ -0,0 +1,173 @@
+with H3.Pool;
+with H3.Limited_Pool;
+with H3.Strings;
+with H3.Storage_Pools;
+with H3.MM;
+with GNAT.Debug_Pools;
+with System.Storage_Pools;
+with System.Pool_Global;
+with Ada.Unchecked_Deallocation;
+with Ada.Text_IO;
+with Ada.Wide_Text_IO;
+
+procedure hello is
+	package S is new H3.Strings(Wide_Character, Wide_Character'Val(0));
+
+	--type Global_Pool is new System.Storage_Pools.Root_Storage_Pool with null record;
+	P1: aliased System.Pool_Global.Unbounded_No_Reclaim_Pool;
+	P2: aliased GNAT.Debug_Pools.Debug_Pool;
+	P3: aliased H3.Storage_Pools.Global_Pool;
+
+	type T is record
+		A: Integer := 99;
+		B: Integer := 88;
+		C: Float;
+	end record;
+
+	type L is limited record
+		A: Integer := 1234;
+		B: Integer;
+		C: Float;
+	end record;
+
+	type T_Pointer is access T;
+	package TP is new H3.Pool(T, T_Pointer, P1'Unchecked_Access);
+
+	type L_Pointer is access L;
+	package LP is new H3.Limited_Pool(L, L_Pointer, P1'Unchecked_Access);
+
+	type I_Pointer is access Integer;
+	package IP is new H3.Pool(Integer, I_Pointer, P1'Unchecked_Access);
+
+ 	procedure Info is new GNAT.Debug_Pools.Print_Info(Ada.Text_IO.Put_Line, Ada.Text_IO.Put);
+
+	x: T_Pointer;
+	i: I_Pointer;
+	y: L_Pointer;
+
+	SS: S.Elastic_String;
+begin
+	x := TP.Allocate((A => 900, B => 800, C => 1.1));
+	i := IP.Allocate(200);
+
+	y := LP.Allocate;
+-- can't do this as it's limited
+	--y.all := (A => 1900, B => 1800, C => 11.1);
+-- this works...
+	--y.A := 1900;
+	y.B := 1800;
+	y.C := 11.1;
+
+	declare
+		type LL_Pointer is access L;
+		for LL_Pointer'Storage_Pool use P3;
+		z: LL_Pointer;
+		procedure Dealloc is new Ada.Unchecked_Deallocation(L, LL_Pointer);
+	begin
+		z := new L'(A => 9900, B => 9800, C => 99.1);	
+		Ada.Text_IO.Put_Line (Z.A'Img);
+		Dealloc (z);
+	end;
+
+
+	Ada.Text_IO.Put_Line(Integer'Image(x.A));
+	Ada.Text_IO.Put_Line(Integer'Image(x.B));
+	Ada.Text_IO.Put_Line(Integer'Image(i.all));
+	Ada.Text_IO.Put_Line(Integer'Image(y.A));
+
+	IP.Deallocate (i);
+	TP.Deallocate (x);
+	LP.Deallocate (y);
+	
+ 	--GNAT.Debug_Pools.Print_Info_Stdout(P2);
+ 	--GNAT.Debug_Pools.Dump_Stdout(P2,  100);
+	
+	declare
+		str: S.Elastic_String;
+		len: H3.System_Size;
+		capa: H3.System_Size;
+	begin
+		len := S.Get_Length(Str);
+		capa := S.Get_Capacity(Str);
+		Ada.Text_IO.Put_Line ("length=>" & len'Img & " Capacity=>" & capa'Img);
+
+		S.Append(Str, "Hello, world");
+		len := S.Get_Length(Str);
+		capa := S.Get_Capacity(Str);
+		Ada.Text_IO.Put_Line ("length=>" & len'Img & " Capacity=>" & capa'Img);
+
+		S.Append(Str, "");
+		len := S.Get_Length(Str);
+		capa := S.Get_Capacity(Str);
+		Ada.Text_IO.Put_Line ("length=>" & len'Img & " Capacity=>" & capa'Img);
+
+		S.Append(Str, "donkey");
+		len := S.Get_Length(Str);
+		capa := S.Get_Capacity(Str);
+		Ada.Text_IO.Put_Line ("length=>" & len'Img & " Capacity=>" & capa'Img);
+
+		
+		declare
+			arr: constant S.Character_Array := S.To_Character_Array(str);
+		begin
+			Ada.Wide_Text_IO.Put ("[");	
+			for i in arr'Range loop
+				Ada.Wide_Text_IO.Put (arr(i));	
+			end loop;
+			Ada.Wide_Text_IO.Put_Line ("]");	
+		end;
+		
+		-- unsafe way to access the internal buffer.
+		S.Append (Str, 'X');
+		declare
+			arr: constant S.Thin_Character_Array_Pointer := S.Get_Slot_Pointer(Str);
+			use type H3.System_Word;
+		begin
+			Ada.Wide_Text_IO.Put ("[");	
+			for i in 1 .. S.Get_Length(Str) + 1 loop
+				Ada.Wide_Text_IO.Put (arr.all(i));
+			end loop;
+			Ada.Wide_Text_IO.Put_Line ("]");	
+		end;
+
+		--declare
+		--	arr: constant Standard.Wide_String := S.To_Character_Array(str);
+		--begin
+		--	Ada.Wide_Text_IO.Put_Line (arr);	
+		--end;
+		SS := Str;
+	end;
+
+	declare
+		type R_Record is record
+			X: Standard.Integer := 3;
+			Y: Standard.Integer := 4;
+		end record;
+		package Q is new H3.MM(R_Record);
+
+		T: Q.Ref_Counted;
+		T2: Q.Ref_Counted;
+
+		P: Q.Item_Pointer;
+	begin
+
+		declare
+			T3: Q.Ref_Counted;
+		begin
+			Q.Create (T3, (X => 20, Y => 30));	
+			T := T3;
+			--Q.Create (T);
+		end;
+
+		P := Q.Get_Item_Pointer(T);
+		T2 := T;
+		Q.Get_Item_Pointer(T).X := 12345;
+		Ada.Text_IO.Put_Line(Q.Get_Item_Pointer(T).Y'Img);
+		Ada.Text_IO.Put_Line(Q.Get_Item_Pointer(T).X'Img);
+		
+		Ada.Text_IO.Put_Line(Q.Get_Item_Pointer(T2).Y'Img);
+		Ada.Text_IO.Put_Line(Q.Get_Item_Pointer(T2).X'Img);
+	end;
+
+end;
+