diff --git a/lib2/Makefile b/lib2/Makefile new file mode 100644 index 0000000..2437039 --- /dev/null +++ b/lib2/Makefile @@ -0,0 +1,3 @@ +all: + gnat make -gnata hello && valgrind ./hello + gnat make -gnata hello2 && valgrind ./hello2 diff --git a/lib2/h3-arrays.adb b/lib2/h3-arrays.adb new file mode 100644 index 0000000..c47b2e9 --- /dev/null +++ b/lib2/h3-arrays.adb @@ -0,0 +1,341 @@ +with Ada.Unchecked_Deallocation; + +package body H3.Arrays is + BUFFER_ALIGN: constant := 128; -- TODO: change it to a reasonably large value. + + type Shift_Direction is (SHIFT_LEFT, SHIFT_RIGHT); + + function To_Item_Array (Str: in Elastic_Array) return Item_Array is + begin + return Str.Buffer.Slot(Str.Buffer.Slot'First .. Str.Buffer.Last); + end To_Item_Array; + + -- return the buffer capacity excluding the terminator + function Get_Capacity (Str: in Elastic_Array) return System_Size is + begin + return Str.Buffer.Slot'Length - Terminator_Length; + end Get_Capacity; + + -- private. return the buffer capacity including the terminator + function Get_Hard_Capacity (Str: in Elastic_Array) return System_Size is + begin + return Str.Buffer.Slot'Length; + end Get_Hard_Capacity; + pragma Inline (Get_Hard_Capacity); + + function Get_Length (Str: in Elastic_Array) return System_Size is + begin + return 1 + Str.Buffer.Last - Str.Buffer.Slot'First; + end Get_Length; + + function Get_First_Index (Str: in Elastic_Array) return System_Size is + begin + return Str.Buffer.Slot'First; + end Get_First_Index; + + function Get_Last_Index (Str: in Elastic_Array) return System_Size is + begin + return Str.Buffer.Last; + end Get_Last_Index; + + function Get_Item (Str: in Elastic_Array; Pos: in System_Index) return Item_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_Array) return Thin_Item_Array_Pointer is + A: System.Address := Str.Buffer.Slot(Str.Buffer.Slot'First)'Address; + P: Thin_Item_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_Array) 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_Array) 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 + Buf.Refs := Buf.Refs + 1; + end if; + end Ref_Buffer; + + procedure Unref_Buffer (Buf: in out Buffer_Pointer) is + begin + if Buf /= Empty_Buffer'Access then + if Buf.Refs = 1 then + declare + procedure Free is new Ada.Unchecked_Deallocation(Buffer_Record, Buffer_Pointer); + begin + Free (Buf); + end; + Buf := Empty_Buffer'Access; + else + Buf.Refs := Buf.Refs - 1; + end if; + end if; + end Unref_Buffer; + + function New_Buffer_Container (Hard_Capa: in System_Size) return Elastic_Array is + Tmp: Elastic_Array; + begin + Tmp.Buffer := new Buffer_Record(Hard_Capa); + Tmp.Buffer.Refs := 1; + return Tmp; + end New_Buffer_Container; + + -- prepare the buffer for writing + procedure Prepare_Buffer (Str: in out Elastic_Array) is + Tmp: Elastic_Array; + begin + if Str.Buffer /= Empty_Buffer'Access then + if Is_Shared(Str) then + -- The code like this doesn't work correctly in terms of finalization. + -- The buffer pointer held inside a finalization controlled record must be + -- manipluated through the record itself. otherwise, the Adjust and Finalize + -- calls goes incompatible with the reference counting implementation. + -- It is because finalization is set on the record rather than the buffer pointer. + --Tmp: Buffer_Pointer; + --Tmp := new Buffer_Record(Get_Hard_Capacity(Str)); + --Tmp.Slot := Str.Buffer.Slot; + --Tmp.Last := Str.Buffer.Last; + --Tmp.Refs := 1; + --Unref_Buffer (Str.Buffer); + --Str.Buffer := Tmp; + Tmp := Str; + Str := New_Buffer_Container(Get_Hard_Capacity(Str)); + Str.Buffer.Slot := Tmp.Buffer.Slot; + Str.Buffer.Last := Tmp.Buffer.Last; + end if; + end if; + end Prepare_Buffer; + + -- prepare the buffer for writing + procedure Prepare_Buffer (Str: in out Elastic_Array; Req_Hard_Capa: in System_Size; Shift_Pos: in System_Size := 0; Shift_Size: in System_Size := 0; Shift_Dir: in Shift_Direction := Shift_Right) is + Tmp: Elastic_Array; + First, Last: System_Size; + Hard_Capa: System_Size; + begin + First := Get_First_Index(Str); + Last := Get_Last_Index(Str); + + if Str.Buffer /= Empty_Buffer'Access and then Is_Shared(Str) then + if Req_Hard_Capa < Get_Hard_Capacity(Str) then + Hard_Capa := Get_Hard_Capacity(Str); + else + Hard_Capa := Req_Hard_Capa; + end if; + + Tmp := Str; + Str := New_Buffer_Container(Hard_Capa); + goto COPY_OVER; + else + if Req_Hard_Capa > Get_Hard_Capacity(Str) then + Tmp := Str; + Str := New_Buffer_Container(Req_Hard_Capa); + goto COPY_OVER; + elsif Shift_Pos > 0 then + Tmp := Str; + goto COPY_OVER_WITH_SHIFT; + else + -- no shift, no change in the buffer + null; + end if; + end if; + + return; + + <> + if Shift_Pos <= 0 then + -- no shift is required. copy the entire Array including th + Str.Buffer.Slot(First .. Last + Terminator_Length) := Tmp.Buffer.Slot(First .. Last + Terminator_Length); + Str.Buffer.Last := Last; + return; + end if; + <> + -- it is an internal function. perform no sanity check. + -- if Shift_Pos or Shift_Size is beyond the allocated capacity, + -- it will end up in an exception. + if Shift_Dir = SHIFT_LEFT then + declare + Mid: System_Size := Shift_Pos - Shift_Size; + begin + Str.Buffer.Slot(First .. Mid) := Tmp.Buffer.Slot(First .. Mid); + Str.Buffer.Slot(Mid + 1 .. Last - Shift_Size + Terminator_Length) := Tmp.Buffer.Slot(Shift_Pos + 1 .. Last + Terminator_Length); + Str.Buffer.Last := Last - Shift_Size; + end; + else + Str.Buffer.Slot(First .. Shift_Pos - 1) := Tmp.Buffer.Slot(First .. Shift_Pos - 1); + Str.Buffer.Slot(Shift_Pos + Shift_Size .. Last + Shift_Size + Terminator_Length) := Tmp.Buffer.Slot(Shift_Pos .. Last + Terminator_Length); + Str.Buffer.Last := Last + Shift_Size; + end if; + end Prepare_Buffer; + + procedure Clear (Str: in out Elastic_Array) is + begin + Prepare_Buffer (Elastic_Array(Str)); + Str.Buffer.Last := Get_First_Index(Str) - 1; + Str.Buffer.Slot(Get_First_Index(Str) .. Get_First_Index(Str) + Terminator_Length - 1) := (others => Terminator_Value); + end Clear; + + procedure Purge (Str: in out Elastic_Array) is + begin + Unref_Buffer (Str.Buffer); + Str.Buffer := Empty_Buffer'Access; + end Purge; + + function Calc_Inc_Capa (Str: in Elastic_Array; Inc: in System_Size) return System_Size is + begin + return H3.Align(Get_Length(Str) + Inc + Terminator_Length, BUFFER_ALIGN); + end Calc_Inc_Capa; + + procedure Insert (Str: in out Elastic_Array; Pos: in System_Index; V: in Item_Type; Repeat: in System_Size := 1) is + Act_Pos: System_Index := Pos; + Act_Inc: System_Size := Repeat; + begin + if Act_Pos > Str.Buffer.Last then + Act_Pos := Str.Buffer.Last + 1; + end if; + + Prepare_Buffer (Elastic_Array(Str), Calc_Inc_Capa(Str, Act_Inc), Act_Pos, Act_Inc); + Str.Buffer.Slot(Act_Pos .. Act_Pos + Act_Inc - 1) := (others => V); + end Insert; + + procedure Insert (Str: in out Elastic_Array; Pos: in System_Index; V: in Item_Array) is + Act_Pos: System_Index := Pos; + begin + if Act_Pos > Str.Buffer.Last then + Act_Pos := Str.Buffer.Last + 1; + end if; + + Prepare_Buffer (Elastic_Array(Str), Calc_Inc_Capa(Str, V'Length), Act_Pos, V'Length); + Str.Buffer.Slot(Act_Pos .. Act_Pos + V'Length - 1) := V; + end Insert; + +-- TODO: operator "&" that returns a new Elastic_Array + procedure Append (Str: in out Elastic_Array; V: in Item_Type; Repeat: in System_Size := 1) is + begin + Insert (Str, Get_Last_Index(Str) + 1, V, Repeat); + end Append; + + procedure Append (Str: in out Elastic_Array; V: in Item_Array) is + begin + Insert (Str, Get_Last_Index(Str) + 1, V); + end Append; + + procedure Prepend (Str: in out Elastic_Array; V: in Item_Type; Repeat: in System_Size := 1) is + begin + Insert (Str, Get_First_Index(Str), V, Repeat); + end Prepend; + + procedure Prepend (Str: in out Elastic_Array; V: in Item_Array) is + begin + Insert (Str, Get_First_Index(Str), V); + end Prepend; + + procedure Replace (Str: in out Elastic_Array; From_Pos: in System_Index; To_Pos: in System_Size; V: in Item_Type; Repeat: in System_Size := 1) is + Act_To_Pos, Repl_Len: System_Size; + begin + if From_Pos <= To_Pos and then From_Pos <= Str.Buffer.Last then + Act_To_Pos := To_Pos; + if Act_To_Pos > Str.Buffer.Last then + Act_To_Pos := Str.Buffer.Last; + end if; + + Repl_Len := Act_To_Pos - From_Pos + 1; + if Repeat < Repl_Len then + Prepare_Buffer (Elastic_Array(Str), Get_Hard_Capacity(Str), Act_To_Pos, Repl_Len - Repeat, SHIFT_LEFT); + Act_To_Pos := From_Pos + Repeat - 1; + elsif Repeat > Repl_Len then + Prepare_Buffer (Elastic_Array(Str), Calc_Inc_Capa(Str, Repeat - Repl_Len), From_Pos, Repeat - Repl_Len, SHIFT_RIGHT); + Act_To_Pos := From_Pos + Repeat - 1; + else + Prepare_Buffer (Elastic_Array(Str)); + end if; + Str.Buffer.Slot(From_Pos .. Act_To_Pos) := (others => V); + end if; + end Replace; + + procedure Replace (Str: in out Elastic_Array; From_Pos: in System_Index; To_Pos: in System_Size; V: in Item_Array) is + Act_To_Pos, Repl_Len: System_Size; + begin + if From_Pos <= To_Pos and then From_Pos <= Str.Buffer.Last then + Act_To_Pos := To_Pos; + if Act_To_Pos > Str.Buffer.Last then + Act_To_Pos := Str.Buffer.Last; + end if; + + Repl_Len := Act_To_Pos - From_Pos + 1; + if V'Length < Repl_Len then + Prepare_Buffer (Elastic_Array(Str), Get_Hard_Capacity(Str), Act_To_Pos, Repl_Len - V'Length, SHIFT_LEFT); + Act_To_Pos := From_Pos + V'Length - 1; + elsif V'Length > Repl_Len then + Prepare_Buffer (Elastic_Array(Str), Calc_Inc_Capa(Str, V'Length - Repl_Len), From_Pos, V'Length - Repl_Len, SHIFT_RIGHT); + Act_To_Pos := From_Pos + V'Length - 1; + else + Prepare_Buffer (Elastic_Array(Str)); + end if; + Str.Buffer.Slot(From_Pos .. Act_To_Pos) := V; + end if; + end Replace; + + procedure Delete (Str: in out Elastic_Array; From_Pos: in System_Index; To_Pos: in System_Size) is + Act_To_Pos: System_Size; + begin + if From_Pos <= To_Pos and then From_Pos <= Str.Buffer.Last then + Act_To_Pos := To_Pos; + if Act_To_Pos > Str.Buffer.Last then + Act_To_Pos := Str.Buffer.Last; + end if; + Prepare_Buffer (Elastic_Array(Str), Get_Hard_Capacity(Str), Act_To_Pos, Act_To_Pos - From_Pos + 1, SHIFT_LEFT); + end if; + end Delete; + + function "=" (Str: in Elastic_Array; Str2: in Elastic_Array) return Standard.Boolean is + begin + return Str.Buffer = Str2.Buffer or else Str.Buffer.Slot(Get_First_Index(Str) .. Get_Last_Index(Str)) = Str2.Buffer.Slot(Get_First_Index(Str2) .. Get_Last_Index(Str2)); + end "="; + + function "=" (Str: in Elastic_Array; Str2: in Item_Array) return Standard.Boolean is + begin + return Str.Buffer.Slot(Get_First_Index(Str) .. Get_Last_Index(Str)) = Str2; + end "="; + + -- --------------------------------------------------------------------- + -- Controlled Management + -- --------------------------------------------------------------------- + procedure Initialize (Str: in out Elastic_Array) is + begin + -- the Array is initialized to the empty buffer all the time. + -- there is no need to reference the buffer. + null; + end Initialize; + + procedure Adjust (Str: in out Elastic_Array) is + begin + Ref_Buffer (Str.Buffer); + end Adjust; + + procedure Finalize (Str: in out Elastic_Array) is + begin + Unref_Buffer (Str.Buffer); + end Finalize; + +end H3.Arrays; diff --git a/lib2/h3-arrays.ads b/lib2/h3-arrays.ads new file mode 100644 index 0000000..602b376 --- /dev/null +++ b/lib2/h3-arrays.ads @@ -0,0 +1,87 @@ +with Ada.Finalization; + +generic + --type Item_Type is private; + type Item_Type is (<>); + G_Terminator_Length: System_Zero_Or_One; + G_Terminator_Value: Item_Type; +package H3.Arrays is + + Terminator_Length: constant System_Zero_Or_One := G_Terminator_Length; + Terminator_Value: constant Item_Type := G_Terminator_Value; + + type Elastic_Array is tagged private; + type Item_Array is array(System_Index range <>) of Item_Type; + --type Item_Array_Pointer is access all Item_Array; + + subtype Thin_Item_Array is Item_Array(System_Index'Range); + type Thin_Item_Array_Pointer is access Thin_Item_Array; + + function To_Item_Array (Str: in Elastic_Array) return Item_Array; + + function Get_Capacity (Str: in Elastic_Array) return System_Size; + pragma Inline (Get_Capacity); + + function Get_Length (Str: in Elastic_Array) return System_Size; + pragma Inline (Get_Length); + + -- the return type is System_Size for consistency with Get_Last_Index. + function Get_First_Index (Str: in Elastic_Array) return System_Size; + pragma Inline (Get_First_Index); + + -- the return type is System_Size because the Last index is -1 off the System_Index'First for an empty array + function Get_Last_Index (Str: in Elastic_Array) return System_Size; + pragma Inline (Get_Last_index); + + function Get_Item (Str: in Elastic_Array; Pos: in System_Index) return Item_Type; + pragma Inline (Get_Item); + + -- unsafe + function Get_Slot_Pointer (Str: in Elastic_Array) return Thin_Item_Array_Pointer; + pragma Inline (Get_Slot_Pointer); + + function Is_Shared(Str: in Elastic_Array) return Standard.Boolean; + pragma Inline (Is_Shared); + + procedure Clear (Str: in out Elastic_Array); + procedure Purge (Str: in out Elastic_Array); -- clear and reset the buffer to Empty_Buffer. + + procedure Insert (Str: in out Elastic_Array; Pos: in System_Index; V: in Item_Type; Repeat: in System_Size := 1); + procedure Insert (Str: in out Elastic_Array; Pos: in System_Index; V: in Item_Array); + + procedure Append (Str: in out Elastic_Array; V: in Item_Type; Repeat: in System_Size := 1); + procedure Append (Str: in out Elastic_Array; V: in Item_Array); + + procedure Prepend (Str: in out Elastic_Array; V: in Item_Type; Repeat: in System_Size := 1); + procedure Prepend (Str: in out Elastic_Array; V: in Item_Array); + + procedure Replace (Str: in out Elastic_Array; From_Pos: in System_Index; To_Pos: in System_Size; V: in Item_Type; Repeat: in System_Size := 1); + procedure Replace (Str: in out Elastic_Array; From_Pos: in System_Index; To_Pos: in System_Size; V: in Item_Array); + + procedure Delete (Str: in out Elastic_Array; From_Pos: in System_Index; To_Pos: in System_Size); + + function "=" (Str: in Elastic_Array; Str2: in Elastic_Array) return Standard.Boolean; + function "=" (Str: in Elastic_Array; Str2: in Item_Array) return Standard.Boolean; + +private + type Buffer_Record(Capa: System_Size) is limited record + Refs: System_Size := 1; + Slot: Item_Array(1 .. Capa) := (others => Terminator_Value); + Last: System_Size := 0; + end record; + + type Buffer_Pointer is access all Buffer_Record; + + --Empty_Buffer: aliased Buffer_Record(1); + -- Use 1 slot to hold the terminator value regardless of th terminator length in Empty_Buffer. + Empty_Buffer: aliased Buffer_Record := (Capa => 1, Refs => 0, Slot => (1 => Terminator_Value), Last => 0); + + type Elastic_Array is new Ada.Finalization.Controlled with record + Buffer: Buffer_Pointer := Empty_Buffer'Access; + end record; + + overriding procedure Initialize (Str: in out Elastic_Array); + overriding procedure Adjust (Str: in out Elastic_Array); + overriding procedure Finalize (Str: in out Elastic_Array); + +end H3.Arrays; diff --git a/lib2/h3-strings.adb b/lib2/h3-strings.adb index 44a431d..d86eb35 100644 --- a/lib2/h3-strings.adb +++ b/lib2/h3-strings.adb @@ -1,340 +1,8 @@ -with Ada.Unchecked_Deallocation; - package body H3.Strings is - BUFFER_ALIGN: constant := 128; -- TODO: change it to a reasonably large value. - type Shift_Direction is (SHIFT_LEFT, SHIFT_RIGHT); - - function To_Item_Array (Str: in Elastic_String) return Item_Array is + procedure Append (Str: in out Elastic_String; V: in Character_Array) is begin - return Str.Buffer.Slot(Str.Buffer.Slot'First .. Str.Buffer.Last); - end To_Item_Array; - - -- return the buffer capacity excluding the terminator - function Get_Capacity (Str: in Elastic_String) return System_Size is - begin - return Str.Buffer.Slot'Length - Terminator_Length; - end Get_Capacity; - - -- private. return the buffer capacity including the terminator - function Get_Hard_Capacity (Str: in Elastic_String) return System_Size is - begin - return Str.Buffer.Slot'Length; - end Get_Hard_Capacity; - pragma Inline (Get_Hard_Capacity); - - function Get_Length (Str: in Elastic_String) return System_Size is - begin - return 1 + Str.Buffer.Last - Str.Buffer.Slot'First; - end Get_Length; - - function Get_First_Index (Str: in Elastic_String) return System_Size is - begin - return Str.Buffer.Slot'First; - end Get_First_Index; - - function Get_Last_Index (Str: in Elastic_String) return System_Size is - begin - return Str.Buffer.Last; - end Get_Last_Index; - - function Get_Item (Str: in Elastic_String; Pos: in System_Index) return Item_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_Item_Array_Pointer is - A: System.Address := Str.Buffer.Slot(Str.Buffer.Slot'First)'Address; - P: Thin_Item_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 - Buf.Refs := Buf.Refs + 1; - end if; - end Ref_Buffer; - - procedure Unref_Buffer (Buf: in out Buffer_Pointer) is - begin - if Buf /= Empty_Buffer'Access then - if Buf.Refs = 1 then - declare - procedure Free is new Ada.Unchecked_Deallocation(Buffer_Record, Buffer_Pointer); - begin - Free (Buf); - end; - Buf := Empty_Buffer'Access; - else - Buf.Refs := Buf.Refs - 1; - end if; - end if; - end Unref_Buffer; - - function New_Buffer_Container (Hard_Capa: in System_Size) return Elastic_String is - Tmp: Elastic_String; - begin - Tmp.Buffer := new Buffer_Record(Hard_Capa); - Tmp.Buffer.Refs := 1; - return Tmp; - end New_Buffer_Container; - - -- prepare the buffer for writing - procedure Prepare_Buffer (Str: in out Elastic_String) is - Tmp: Elastic_String; - begin - if Str.Buffer /= Empty_Buffer'Access then - if Is_Shared(Str) then - -- The code like this doesn't work correctly in terms of finalization. - -- The buffer pointer held inside a finalization controlled record must be - -- manipluated through the record itself. otherwise, the Adjust and Finalize - -- calls goes incompatible with the reference counting implementation. - -- It is because finalization is set on the record rather than the buffer pointer. - --Tmp: Buffer_Pointer; - --Tmp := new Buffer_Record(Get_Hard_Capacity(Str)); - --Tmp.Slot := Str.Buffer.Slot; - --Tmp.Last := Str.Buffer.Last; - --Tmp.Refs := 1; - --Unref_Buffer (Str.Buffer); - --Str.Buffer := Tmp; - Tmp := Str; - Str := New_Buffer_Container(Get_Hard_Capacity(Str)); - Str.Buffer.Slot := Tmp.Buffer.Slot; - Str.Buffer.Last := Tmp.Buffer.Last; - end if; - end if; - end Prepare_Buffer; - - -- prepare the buffer for writing - procedure Prepare_Buffer (Str: in out Elastic_String; Req_Hard_Capa: in System_Size; Shift_Pos: in System_Size := 0; Shift_Size: in System_Size := 0; Shift_Dir: in Shift_Direction := Shift_Right) is - Tmp: Elastic_String; - First, Last: System_Size; - Hard_Capa: System_Size; - begin - First := Get_First_Index(Str); - Last := Get_Last_Index(Str); - - if Str.Buffer /= Empty_Buffer'Access and then Is_Shared(Str) then - if Req_Hard_Capa < Get_Hard_Capacity(Str) then - Hard_Capa := Get_Hard_Capacity(Str); - else - Hard_Capa := Req_Hard_Capa; - end if; - - Tmp := Str; - Str := New_Buffer_Container(Hard_Capa); - goto COPY_OVER; - else - if Req_Hard_Capa > Get_Hard_Capacity(Str) then - Tmp := Str; - Str := New_Buffer_Container(Req_Hard_Capa); - goto COPY_OVER; - elsif Shift_Pos > 0 then - Tmp := Str; - goto COPY_OVER_WITH_SHIFT; - else - -- no shift, no change in the buffer - null; - end if; - end if; - - return; - - <> - if Shift_Pos <= 0 then - -- no shift is required. copy the entire string including th - Str.Buffer.Slot(First .. Last + Terminator_Length) := Tmp.Buffer.Slot(First .. Last + Terminator_Length); - Str.Buffer.Last := Last; - return; - end if; - <> - -- it is an internal function. perform no sanity check. - -- if Shift_Pos or Shift_Size is beyond the allocated capacity, - -- it will end up in an exception. - if Shift_Dir = SHIFT_LEFT then - declare - Mid: System_Size := Shift_Pos - Shift_Size; - begin - Str.Buffer.Slot(First .. Mid) := Tmp.Buffer.Slot(First .. Mid); - Str.Buffer.Slot(Mid + 1 .. Last - Shift_Size + Terminator_Length) := Tmp.Buffer.Slot(Shift_Pos + 1 .. Last + Terminator_Length); - Str.Buffer.Last := Last - Shift_Size; - end; - else - Str.Buffer.Slot(First .. Shift_Pos - 1) := Tmp.Buffer.Slot(First .. Shift_Pos - 1); - Str.Buffer.Slot(Shift_Pos + Shift_Size .. Last + Shift_Size + Terminator_Length) := Tmp.Buffer.Slot(Shift_Pos .. Last + Terminator_Length); - Str.Buffer.Last := Last + Shift_Size; - end if; - end Prepare_Buffer; - - procedure Clear (Str: in out Elastic_String) is - begin - Prepare_Buffer (Str); - Str.Buffer.Last := Get_First_Index(Str) - 1; - end Clear; - - procedure Purge (Str: in out Elastic_String) is - begin - Unref_Buffer (Str.Buffer); - Str.Buffer := Empty_Buffer'Access; - end Purge; - - function Calc_Inc_Capa (Str: in Elastic_String; Inc: in System_Size) return System_Size is - begin - return H3.Align(Get_Length(Str) + Inc + Terminator_Length, BUFFER_ALIGN); - end Calc_Inc_Capa; - - procedure Insert (Str: in out Elastic_String; Pos: in System_Index; V: in Item_Type; Repeat: in System_Size := 1) is - Act_Pos: System_Index := Pos; - Act_Inc: System_Size := Repeat; - begin - if Act_Pos > Str.Buffer.Last then - Act_Pos := Str.Buffer.Last + 1; - end if; - - Prepare_Buffer (Str, Calc_Inc_Capa(Str, Act_Inc), Act_Pos, Act_Inc); - Str.Buffer.Slot(Act_Pos .. Act_Pos + Act_Inc - 1) := (others => V); - end Insert; - - procedure Insert (Str: in out Elastic_String; Pos: in System_Index; V: in Item_Array) is - Act_Pos: System_Index := Pos; - begin - if Act_Pos > Str.Buffer.Last then - Act_Pos := Str.Buffer.Last + 1; - end if; - - Prepare_Buffer (Str, Calc_Inc_Capa(Str, V'Length), Act_Pos, V'Length); - Str.Buffer.Slot(Act_Pos .. Act_Pos + V'Length - 1) := V; - end Insert; - --- TODO: operator "&" that returns a new Elastic_String - procedure Append (Str: in out Elastic_String; V: in Item_Type; Repeat: in System_Size := 1) is - begin - Insert (Str, Get_Last_Index(Str) + 1, V, Repeat); - end Append; - - procedure Append (Str: in out Elastic_String; V: in Item_Array) is - begin - Insert (Str, Get_Last_Index(Str) + 1, V); - end Append; - - procedure Prepend (Str: in out Elastic_String; V: in Item_Type; Repeat: in System_Size := 1) is - begin - Insert (Str, Get_First_Index(Str), V, Repeat); - end Prepend; - - procedure Prepend (Str: in out Elastic_String; V: in Item_Array) is - begin - Insert (Str, Get_First_Index(Str), V); - end Prepend; - - procedure Replace (Str: in out Elastic_String; From_Pos: in System_Index; To_Pos: in System_Size; V: in Item_Type; Repeat: in System_Size := 1) is - Act_To_Pos, Repl_Len: System_Size; - begin - if From_Pos <= To_Pos and then From_Pos <= Str.Buffer.Last then - Act_To_Pos := To_Pos; - if Act_To_Pos > Str.Buffer.Last then - Act_To_Pos := Str.Buffer.Last; - end if; - - Repl_Len := Act_To_Pos - From_Pos + 1; - if Repeat < Repl_Len then - Prepare_Buffer (Str, Get_Hard_Capacity(Str), Act_To_Pos, Repl_Len - Repeat, SHIFT_LEFT); - Act_To_Pos := From_Pos + Repeat - 1; - elsif Repeat > Repl_Len then - Prepare_Buffer (Str, Calc_Inc_Capa(Str, Repeat - Repl_Len), From_Pos, Repeat - Repl_Len, SHIFT_RIGHT); - Act_To_Pos := From_Pos + Repeat - 1; - else - Prepare_Buffer (Str); - end if; - Str.Buffer.Slot(From_Pos .. Act_To_Pos) := (others => V); - end if; - end Replace; - - procedure Replace (Str: in out Elastic_String; From_Pos: in System_Index; To_Pos: in System_Size; V: in Item_Array) is - Act_To_Pos, Repl_Len: System_Size; - begin - if From_Pos <= To_Pos and then From_Pos <= Str.Buffer.Last then - Act_To_Pos := To_Pos; - if Act_To_Pos > Str.Buffer.Last then - Act_To_Pos := Str.Buffer.Last; - end if; - - Repl_Len := Act_To_Pos - From_Pos + 1; - if V'Length < Repl_Len then - Prepare_Buffer (Str, Get_Hard_Capacity(Str), Act_To_Pos, Repl_Len - V'Length, SHIFT_LEFT); - Act_To_Pos := From_Pos + V'Length - 1; - elsif V'Length > Repl_Len then - Prepare_Buffer (Str, Calc_Inc_Capa(Str, V'Length - Repl_Len), From_Pos, V'Length - Repl_Len, SHIFT_RIGHT); - Act_To_Pos := From_Pos + V'Length - 1; - else - Prepare_Buffer (Str); - end if; - Str.Buffer.Slot(From_Pos .. Act_To_Pos) := V; - end if; - end Replace; - - procedure Delete (Str: in out Elastic_String; From_Pos: in System_Index; To_Pos: in System_Size) is - Act_To_Pos: System_Size; - begin - if From_Pos <= To_Pos and then From_Pos <= Str.Buffer.Last then - Act_To_Pos := To_Pos; - if Act_To_Pos > Str.Buffer.Last then - Act_To_Pos := Str.Buffer.Last; - end if; - Prepare_Buffer (Str, Get_Hard_Capacity(Str), Act_To_Pos, Act_To_Pos - From_Pos + 1, SHIFT_LEFT); - end if; - end Delete; - - function "=" (Str: in Elastic_String; Str2: in Elastic_String) return Standard.Boolean is - begin - return Str.Buffer = Str2.Buffer or else Str.Buffer.Slot(Get_First_Index(Str) .. Get_Last_Index(Str)) = Str2.Buffer.Slot(Get_First_Index(Str2) .. Get_Last_Index(Str2)); - end "="; - - function "=" (Str: in Elastic_String; Str2: in Item_Array) return Standard.Boolean is - begin - return Str.Buffer.Slot(Get_First_Index(Str) .. Get_Last_Index(Str)) = Str2; - end "="; - - -- --------------------------------------------------------------------- - -- Controlled Management - -- --------------------------------------------------------------------- - procedure Initialize (Str: in out Elastic_String) is - begin - -- the string is initialized to the empty buffer all the time. - -- there is no need to reference the buffer. - null; - end Initialize; - - procedure Adjust (Str: in out Elastic_String) is - begin - Ref_Buffer (Str.Buffer); - end Adjust; - - procedure Finalize (Str: in out Elastic_String) is - begin - Unref_Buffer (Str.Buffer); - end Finalize; + P.Append (P.Elastic_Array(Str), V); + end; end H3.Strings; diff --git a/lib2/h3-strings.ads b/lib2/h3-strings.ads index 58e7073..329592e 100644 --- a/lib2/h3-strings.ads +++ b/lib2/h3-strings.ads @@ -1,87 +1,23 @@ -with Ada.Finalization; +with H3.Arrays; generic - --type Item_Type is private; type Item_Type is (<>); - G_Terminator_Length: System_Zero_Or_One; G_Terminator_Value: Item_Type; package H3.Strings is - Terminator_Length: constant System_Zero_Or_One := G_Terminator_Length; - Terminator_Value: constant Item_Type := G_Terminator_Value; + package P is new H3.Arrays(Item_Type, 1, G_Terminator_Value); - type Elastic_String is private; - type Item_Array is array(System_Index range <>) of Item_Type; - --type Item_Array_Pointer is access all Item_Array; + Terminator_Length: System_Zero_Or_One renames P.Terminator_Length; + Terminator_Value: Item_Type renames P.Terminator_Value; - subtype Thin_Item_Array is Item_Array(System_Index'Range); - type Thin_Item_Array_Pointer is access Thin_Item_Array; + subtype Character_Array is P.Item_Array; + subtype Thin_Character_Array_Pointer is P.Thin_Item_Array_Pointer; - function To_Item_Array (Str: in Elastic_String) return Item_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); - - -- the return type is System_Size for consistency with Get_Last_Index. - function Get_First_Index (Str: in Elastic_String) return System_Size; - pragma Inline (Get_First_Index); - - -- the return type is System_Size because the Last index is -1 off the System_Index'First for an empty string - function Get_Last_Index (Str: in Elastic_String) return System_Size; - pragma Inline (Get_Last_index); - - function Get_Item (Str: in Elastic_String; Pos: in System_Index) return Item_Type; - pragma Inline (Get_Item); - - -- unsafe - function Get_Slot_Pointer (Str: in Elastic_String) return Thin_Item_Array_Pointer; - pragma Inline (Get_Slot_Pointer); - - function Is_Shared(Str: in Elastic_String) return Standard.Boolean; - pragma Inline (Is_Shared); - - procedure Clear (Str: in out Elastic_String); - procedure Purge (Str: in out Elastic_String); -- clear and reset the buffer to Empty_Buffer. - - procedure Insert (Str: in out Elastic_String; Pos: in System_Index; V: in Item_Type; Repeat: in System_Size := 1); - procedure Insert (Str: in out Elastic_String; Pos: in System_Index; V: in Item_Array); - - procedure Append (Str: in out Elastic_String; V: in Item_Type; Repeat: in System_Size := 1); - procedure Append (Str: in out Elastic_String; V: in Item_Array); - - procedure Prepend (Str: in out Elastic_String; V: in Item_Type; Repeat: in System_Size := 1); - procedure Prepend (Str: in out Elastic_String; V: in Item_Array); - - procedure Replace (Str: in out Elastic_String; From_Pos: in System_Index; To_Pos: in System_Size; V: in Item_Type; Repeat: in System_Size := 1); - procedure Replace (Str: in out Elastic_String; From_Pos: in System_Index; To_Pos: in System_Size; V: in Item_Array); - - procedure Delete (Str: in out Elastic_String; From_Pos: in System_Index; To_Pos: in System_Size); - - function "=" (Str: in Elastic_String; Str2: in Elastic_String) return Standard.Boolean; - function "=" (Str: in Elastic_String; Str2: in Item_Array) return Standard.Boolean; - -private - type Buffer_Record(Capa: System_Size) is limited record - Refs: System_Size := 1; - Slot: Item_Array(1 .. Capa) := (others => Terminator_Value); - Last: System_Size := 0; + type Elastic_String is new P.Elastic_Array with record + --A: standard.integer := 999; + null; end record; - type Buffer_Pointer is access all Buffer_Record; - - --Empty_Buffer: aliased Buffer_Record(1); - -- Use 1 slot to hold the terminator value regardless of th terminator length in Empty_Buffer. - Empty_Buffer: aliased Buffer_Record := (Capa => 1, Refs => 0, Slot => (1 => Terminator_Value), 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); + overriding procedure Append (Str: in out Elastic_String; V: in Character_Array); end H3.Strings; diff --git a/lib2/hello.adb b/lib2/hello.adb index eb0597b..f01b450 100644 --- a/lib2/hello.adb +++ b/lib2/hello.adb @@ -1,5 +1,6 @@ with H3.Pool; with H3.Limited_Pool; +with H3.Arrays; with H3.Strings; with H3.Storage_Pools; with H3.MM; @@ -14,8 +15,8 @@ with Ada.Assertions; use type H3.System_Size; procedure hello is - package S is new H3.Strings(Standard.Wide_Character, 1, Wide_Character'Val(0)); - package S_I is new H3.Strings(Integer, 1, 16#FF#); + package S is new H3.Strings(Standard.Wide_Character, Wide_Character'Val(0)); + package S_I is new H3.Arrays(Integer, 1, 16#FF#); --type Global_Pool is new System.Storage_Pools.Root_Storage_Pool with null record; P1: aliased System.Pool_Global.Unbounded_No_Reclaim_Pool; @@ -174,7 +175,8 @@ begin declare -- unsafe way to access the internal buffer. - arr: constant S.Item_Array := S.To_Item_Array(Str); + --arr: constant S.P.Item_Array := S.To_Item_Array(Str); + arr: constant S.Character_Array := S.To_Item_Array(Str); begin Ada.Wide_Text_IO.Put ("STR[1] => ["); for i in arr'Range loop @@ -353,8 +355,10 @@ begin pragma Assert (S."="(Str2, "Hello, ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ! donkey>donkeyXABCDEEXTRA THIS IS FANTASTIC ELASTIC STRING WRITTEN FOR HH")); declare - arr: constant S.Thin_Item_Array_Pointer := S.Get_Slot_Pointer(Str); - arr2: constant S.Thin_Item_Array_Pointer := S.Get_Slot_Pointer(Str2); + --arr: constant S.P.Thin_Item_Array_Pointer := S.Get_Slot_Pointer(Str); + --arr2: constant S.P.Thin_Item_Array_Pointer := S.Get_Slot_Pointer(Str2); + arr: constant S.Thin_Character_Array_Pointer := S.Get_Slot_Pointer(Str); + arr2: constant S.Thin_Character_Array_Pointer := S.Get_Slot_Pointer(Str2); use type H3.System_Word; begin print_string_info (Str, "Str"); @@ -415,7 +419,7 @@ begin declare - t1: S_I.Elastic_String; + t1: S_I.Elastic_Array; begin S_I.Append (t1, 20, 5); S_I.Prepend (t1, 30, 2);