From e07312b4025038e4e81d0b57983297fad200b246 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Mon, 23 Aug 2021 23:47:29 +0000 Subject: [PATCH] trying to rewrite h2 --- lib2/h3-limited_pool.adb | 61 +++++++++++++ lib2/h3-limited_pool.ads | 24 +++++ lib2/h3-mm.adb | 56 ++++++++++++ lib2/h3-mm.ads | 35 ++++++++ lib2/h3-pool.adb | 95 ++++++++++++++++++++ lib2/h3-pool.ads | 27 ++++++ lib2/h3-storage_pools.adb | 75 ++++++++++++++++ lib2/h3-storage_pools.ads | 26 ++++++ lib2/h3-strings.adb | 178 ++++++++++++++++++++++++++++++++++++++ lib2/h3-strings.ads | 61 +++++++++++++ lib2/h3.adb | 43 +++++++++ lib2/h3.ads | 56 ++++++++++++ lib2/hello.adb | 173 ++++++++++++++++++++++++++++++++++++ 13 files changed, 910 insertions(+) create mode 100644 lib2/h3-limited_pool.adb create mode 100644 lib2/h3-limited_pool.ads create mode 100644 lib2/h3-mm.adb create mode 100644 lib2/h3-mm.ads create mode 100644 lib2/h3-pool.adb create mode 100644 lib2/h3-pool.ads create mode 100644 lib2/h3-storage_pools.adb create mode 100644 lib2/h3-storage_pools.ads create mode 100644 lib2/h3-strings.adb create mode 100644 lib2/h3-strings.ads create mode 100644 lib2/h3.adb create mode 100644 lib2/h3.ads create mode 100644 lib2/hello.adb diff --git a/lib2/h3-limited_pool.adb b/lib2/h3-limited_pool.adb new file mode 100644 index 0000000..ed53693 --- /dev/null +++ b/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; diff --git a/lib2/h3-limited_pool.ads b/lib2/h3-limited_pool.ads new file mode 100644 index 0000000..7fea0e3 --- /dev/null +++ b/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; diff --git a/lib2/h3-mm.adb b/lib2/h3-mm.adb new file mode 100644 index 0000000..aa85acd --- /dev/null +++ b/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; \ No newline at end of file diff --git a/lib2/h3-mm.ads b/lib2/h3-mm.ads new file mode 100644 index 0000000..5260b2a --- /dev/null +++ b/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; \ No newline at end of file diff --git a/lib2/h3-pool.adb b/lib2/h3-pool.adb new file mode 100644 index 0000000..ee48e60 --- /dev/null +++ b/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; diff --git a/lib2/h3-pool.ads b/lib2/h3-pool.ads new file mode 100644 index 0000000..2b8fd01 --- /dev/null +++ b/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; diff --git a/lib2/h3-storage_pools.adb b/lib2/h3-storage_pools.adb new file mode 100644 index 0000000..cc77e92 --- /dev/null +++ b/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; + diff --git a/lib2/h3-storage_pools.ads b/lib2/h3-storage_pools.ads new file mode 100644 index 0000000..dc73306 --- /dev/null +++ b/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; diff --git a/lib2/h3-strings.adb b/lib2/h3-strings.adb new file mode 100644 index 0000000..76382cb --- /dev/null +++ b/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; diff --git a/lib2/h3-strings.ads b/lib2/h3-strings.ads new file mode 100644 index 0000000..8461c86 --- /dev/null +++ b/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; diff --git a/lib2/h3.adb b/lib2/h3.adb new file mode 100644 index 0000000..93bdedb --- /dev/null +++ b/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; \ No newline at end of file diff --git a/lib2/h3.ads b/lib2/h3.ads new file mode 100644 index 0000000..7b9814a --- /dev/null +++ b/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; diff --git a/lib2/hello.adb b/lib2/hello.adb new file mode 100644 index 0000000..85dd8b2 --- /dev/null +++ b/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; +