+2018-08-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * libgnat/g-dynhta.adb, libgnat/g-dynhta.ads: New package
+ Dynamic_HTable.
+
2018-08-21 Javier Miranda <miranda@adacore.com>
* checks.ads (Determine_Range): Adding documentation.
-------------------
package body Static_HTable is
-
function Get_Non_Null (T : Instance) return Elmt_Ptr;
-- Returns Null_Ptr if Iterator_Started is False or if the Table is
- -- empty. Returns Iterator_Ptr if non null, or the next non null
- -- element in table if any.
+ -- empty. Returns Iterator_Ptr if non null, or the next non null element
+ -- in table if any.
---------
-- Get --
begin
E.Next := Next;
end Set_Next;
-
end Simple_HTable;
+ --------------------
+ -- Dynamic_HTable --
+ --------------------
+
+ package body Dynamic_HTable is
+ Minimum_Size : constant Bucket_Range_Type := 32;
+ -- Minimum size of the buckets
+
+ Safe_Compression_Size : constant Bucket_Range_Type :=
+ Minimum_Size * Compression_Factor;
+ -- Maximum safe size for hash table compression. Beyond this size, a
+ -- compression will violate the minimum size constraint on the buckets.
+
+ Safe_Expansion_Size : constant Bucket_Range_Type :=
+ Bucket_Range_Type'Last / Expansion_Factor;
+ -- Maximum safe size for hash table expansion. Beyond this size, an
+ -- expansion will overflow the buckets.
+
+ procedure Destroy_Buckets (Bkts : Bucket_Table_Ptr);
+ pragma Inline (Destroy_Buckets);
+ -- Destroy all nodes within buckets Bkts
+
+ procedure Detach (Nod : Node_Ptr);
+ pragma Inline (Detach);
+ -- Detach node Nod from the bucket it resides in
+
+ procedure Ensure_Circular (Head : Node_Ptr);
+ pragma Inline (Ensure_Circular);
+ -- Ensure that dummy head Head is circular with respect to itself
+
+ procedure Ensure_Created (T : Instance);
+ pragma Inline (Ensure_Created);
+ -- Verify that hash table T is created. Raise Not_Created if this is not
+ -- the case.
+
+ procedure Ensure_Unlocked (T : Instance);
+ pragma Inline (Ensure_Unlocked);
+ -- Verify that hash table T is unlocked. Raise Table_Locked if this is
+ -- not the case.
+
+ function Find_Bucket
+ (Bkts : Bucket_Table_Ptr;
+ Key : Key_Type) return Node_Ptr;
+ pragma Inline (Find_Bucket);
+ -- Find the bucket among buckets Bkts which corresponds to key Key, and
+ -- return its dummy head.
+
+ function Find_Node (Head : Node_Ptr; Key : Key_Type) return Node_Ptr;
+ pragma Inline (Find_Node);
+ -- Traverse a bucket indicated by dummy head Head to determine whether
+ -- there exists a node with key Key. If such a node exists, return it,
+ -- otherwise return null.
+
+ procedure First_Valid_Node
+ (T : Instance;
+ Low_Bkt : Bucket_Range_Type;
+ High_Bkt : Bucket_Range_Type;
+ Idx : out Bucket_Range_Type;
+ Nod : out Node_Ptr);
+ pragma Inline (First_Valid_Node);
+ -- Find the first valid node in the buckets of hash table T constrained
+ -- by the range Low_Bkt .. High_Bkt. If such a node exists, return its
+ -- bucket index in Idx and reference in Nod. If no such node exists,
+ -- Idx is set to 0 and Nod to null.
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Bucket_Table, Bucket_Table_Ptr);
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Hash_Table, Instance);
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Node, Node_Ptr);
+
+ function Is_Valid (Iter : Iterator) return Boolean;
+ pragma Inline (Is_Valid);
+ -- Determine whether iterator Iter refers to a valid key-value pair
+
+ function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean;
+ pragma Inline (Is_Valid);
+ -- Determine whether node Nod is non-null and does not refer to dummy
+ -- head Head, thus making it valid.
+
+ function Load_Factor (T : Instance) return Threshold_Type;
+ pragma Inline (Load_Factor);
+ -- Calculate the load factor of hash table T
+
+ procedure Lock (T : Instance);
+ pragma Inline (Lock);
+ -- Lock all mutation functionality of hash table T
+
+ procedure Mutate_And_Rehash (T : Instance; Size : Bucket_Range_Type);
+ pragma Inline (Mutate_And_Rehash);
+ -- Replace the buckets of hash table T with a new set of buckets of size
+ -- Size. Rehash all key-value pairs from the old to the new buckets.
+
+ procedure Prepend (Nod : Node_Ptr; Head : Node_Ptr);
+ pragma Inline (Prepend);
+ -- Insert node Nod immediately after dummy head Head
+
+ procedure Unlock (T : Instance);
+ pragma Inline (Unlock);
+ -- Unlock all mutation functionality of hash table T
+
+ ------------
+ -- Create --
+ ------------
+
+ function Create (Initial_Size : Bucket_Range_Type) return Instance is
+ Size : constant Bucket_Range_Type :=
+ Bucket_Range_Type'Max (Initial_Size, Minimum_Size);
+ -- Ensure that the buckets meet a minimum size
+
+ T : constant Instance := new Hash_Table;
+
+ begin
+ T.Buckets := new Bucket_Table (0 .. Size - 1);
+ T.Initial_Size := Size;
+
+ return T;
+ end Create;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (T : Instance; Key : Key_Type) is
+ procedure Compress;
+ pragma Inline (Compress);
+ -- Determine whether hash table T requires compression, and if so,
+ -- half its size.
+
+ --------------
+ -- Compress --
+ --------------
+
+ procedure Compress is
+ pragma Assert (T /= null);
+ pragma Assert (T.Buckets /= null);
+
+ Old_Size : constant Bucket_Range_Type := T.Buckets'Length;
+
+ begin
+ -- The ratio of pairs to buckets is under the desited threshold.
+ -- Compress the hash table only when there is still room to do so.
+
+ if Load_Factor (T) < Compression_Threshold
+ and then Old_Size >= Safe_Compression_Size
+ then
+ Mutate_And_Rehash (T, Old_Size / Compression_Factor);
+ end if;
+ end Compress;
+
+ -- Local variables
+
+ Head : Node_Ptr;
+ Nod : Node_Ptr;
+
+ -- Start of processing for Delete
+
+ begin
+ Ensure_Created (T);
+ Ensure_Unlocked (T);
+
+ -- Obtain the dummy head of the bucket which should house the
+ -- key-value pair.
+
+ Head := Find_Bucket (T.Buckets, Key);
+
+ -- Try to find a node in the bucket which matches the key
+
+ Nod := Find_Node (Head, Key);
+
+ -- If such a node exists, remove it from the bucket and deallocate it
+
+ if Is_Valid (Nod, Head) then
+ Detach (Nod);
+ Free (Nod);
+
+ T.Pairs := T.Pairs - 1;
+
+ -- Compress the hash table if the load factor drops below
+ -- Compression_Threshold.
+
+ Compress;
+ end if;
+ end Delete;
+
+ -------------
+ -- Destroy --
+ -------------
+
+ procedure Destroy (T : in out Instance) is
+ begin
+ Ensure_Created (T);
+ Ensure_Unlocked (T);
+
+ -- Destroy all nodes in all buckets
+
+ Destroy_Buckets (T.Buckets);
+ Free (T.Buckets);
+ Free (T);
+ end Destroy;
+
+ ---------------------
+ -- Destroy_Buckets --
+ ---------------------
+
+ procedure Destroy_Buckets (Bkts : Bucket_Table_Ptr) is
+ procedure Destroy_Bucket (Head : Node_Ptr);
+ pragma Inline (Destroy_Bucket);
+ -- Destroy all nodes in a bucket with dummy head Head
+
+ --------------------
+ -- Destroy_Bucket --
+ --------------------
+
+ procedure Destroy_Bucket (Head : Node_Ptr) is
+ Nod : Node_Ptr;
+
+ begin
+ -- Destroy all valid nodes which follow the dummy head
+
+ while Is_Valid (Head.Next, Head) loop
+ Nod := Head.Next;
+
+ Detach (Nod);
+ Free (Nod);
+ end loop;
+ end Destroy_Bucket;
+
+ -- Start of processing for Destroy_Buckets
+
+ begin
+ pragma Assert (Bkts /= null);
+
+ for Scan_Idx in Bkts'Range loop
+ Destroy_Bucket (Bkts (Scan_Idx)'Access);
+ end loop;
+ end Destroy_Buckets;
+
+ ------------
+ -- Detach --
+ ------------
+
+ procedure Detach (Nod : Node_Ptr) is
+ pragma Assert (Nod /= null);
+
+ Next : constant Node_Ptr := Nod.Next;
+ Prev : constant Node_Ptr := Nod.Prev;
+
+ begin
+ pragma Assert (Next /= null);
+ pragma Assert (Prev /= null);
+
+ Prev.Next := Next;
+ Next.Prev := Prev;
+
+ Nod.Next := null;
+ Nod.Prev := null;
+ end Detach;
+
+ ---------------------
+ -- Ensure_Circular --
+ ---------------------
+
+ procedure Ensure_Circular (Head : Node_Ptr) is
+ pragma Assert (Head /= null);
+
+ begin
+ if Head.Next = null and then Head.Prev = null then
+ Head.Next := Head;
+ Head.Prev := Head;
+ end if;
+ end Ensure_Circular;
+
+ --------------------
+ -- Ensure_Created --
+ --------------------
+
+ procedure Ensure_Created (T : Instance) is
+ begin
+ if T = null then
+ raise Not_Created;
+ end if;
+ end Ensure_Created;
+
+ ---------------------
+ -- Ensure_Unlocked --
+ ---------------------
+
+ procedure Ensure_Unlocked (T : Instance) is
+ begin
+ pragma Assert (T /= null);
+
+ -- The hash table has at least one outstanding iterator
+
+ if T.Locked > 0 then
+ raise Table_Locked;
+ end if;
+ end Ensure_Unlocked;
+
+ -----------------
+ -- Find_Bucket --
+ -----------------
+
+ function Find_Bucket
+ (Bkts : Bucket_Table_Ptr;
+ Key : Key_Type) return Node_Ptr
+ is
+ pragma Assert (Bkts /= null);
+
+ Idx : constant Bucket_Range_Type := Hash (Key) mod Bkts'Length;
+
+ begin
+ return Bkts (Idx)'Access;
+ end Find_Bucket;
+
+ ---------------
+ -- Find_Node --
+ ---------------
+
+ function Find_Node (Head : Node_Ptr; Key : Key_Type) return Node_Ptr is
+ pragma Assert (Head /= null);
+
+ Nod : Node_Ptr;
+
+ begin
+ -- Traverse the nodes of the bucket, looking for a key-value pair
+ -- with the same key.
+
+ Nod := Head.Next;
+ while Is_Valid (Nod, Head) loop
+ if Equivalent_Keys (Nod.Key, Key) then
+ return Nod;
+ end if;
+
+ Nod := Nod.Next;
+ end loop;
+
+ return null;
+ end Find_Node;
+
+ ----------------------
+ -- First_Valid_Node --
+ ----------------------
+
+ procedure First_Valid_Node
+ (T : Instance;
+ Low_Bkt : Bucket_Range_Type;
+ High_Bkt : Bucket_Range_Type;
+ Idx : out Bucket_Range_Type;
+ Nod : out Node_Ptr)
+ is
+ Head : Node_Ptr;
+
+ begin
+ pragma Assert (T /= null);
+ pragma Assert (T.Buckets /= null);
+
+ -- Assume that no valid node exists
+
+ Idx := 0;
+ Nod := null;
+
+ -- Examine the buckets of the hash table within the requested range,
+ -- looking for the first valid node.
+
+ for Scan_Idx in Low_Bkt .. High_Bkt loop
+ Head := T.Buckets (Scan_Idx)'Access;
+
+ -- The bucket contains at least one valid node, return the first
+ -- such node.
+
+ if Is_Valid (Head.Next, Head) then
+ Idx := Scan_Idx;
+ Nod := Head.Next;
+ return;
+ end if;
+ end loop;
+ end First_Valid_Node;
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get (T : Instance; Key : Key_Type) return Value_Type is
+ Head : Node_Ptr;
+ Nod : Node_Ptr;
+
+ begin
+ Ensure_Created (T);
+
+ -- Obtain the dummy head of the bucket which should house the
+ -- key-value pair.
+
+ Head := Find_Bucket (T.Buckets, Key);
+
+ -- Try to find a node in the bucket which matches the key
+
+ Nod := Find_Node (Head, Key);
+
+ -- If such a node exists, return the value of the key-value pair
+
+ if Is_Valid (Nod, Head) then
+ return Nod.Value;
+ end if;
+
+ return No_Value;
+ end Get;
+
+ --------------
+ -- Has_Next --
+ --------------
+
+ function Has_Next (Iter : Iterator) return Boolean is
+ Is_OK : constant Boolean := Is_Valid (Iter);
+ T : constant Instance := Iter.Table;
+
+ begin
+ pragma Assert (T /= null);
+
+ -- The iterator is no longer valid which indicates that it has been
+ -- exhausted. Unlock all mutation functionality of the hash table
+ -- because the iterator cannot be advanced any further.
+
+ if not Is_OK then
+ Unlock (T);
+ end if;
+
+ return Is_OK;
+ end Has_Next;
+
+ --------------
+ -- Is_Valid --
+ --------------
+
+ function Is_Valid (Iter : Iterator) return Boolean is
+ begin
+ -- The invariant of Iterate and Next ensures that the iterator always
+ -- refers to a valid node if there exists one.
+
+ return Iter.Nod /= null;
+ end Is_Valid;
+
+ --------------
+ -- Is_Valid --
+ --------------
+
+ function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean is
+ begin
+ -- A node is valid if it is non-null, and does not refer to the dummy
+ -- head of some bucket.
+
+ return Nod /= null and then Nod /= Head;
+ end Is_Valid;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ function Iterate (T : Instance) return Iterator is
+ Iter : Iterator;
+
+ begin
+ Ensure_Created (T);
+ pragma Assert (T.Buckets /= null);
+
+ -- Initialize the iterator to reference the first valid node in
+ -- the full range of hash table buckets. If no such node exists,
+ -- the iterator is left in a state which does not allow it to
+ -- advance.
+
+ First_Valid_Node
+ (T => T,
+ Low_Bkt => T.Buckets'First,
+ High_Bkt => T.Buckets'Last,
+ Idx => Iter.Idx,
+ Nod => Iter.Nod);
+
+ -- Associate the iterator with the hash table to allow for future
+ -- mutation functionality unlocking.
+
+ Iter.Table := T;
+
+ -- Lock all mutation functionality of the hash table while it is
+ -- being iterated on.
+
+ Lock (T);
+
+ return Iter;
+ end Iterate;
+
+ -----------------
+ -- Load_Factor --
+ -----------------
+
+ function Load_Factor (T : Instance) return Threshold_Type is
+ pragma Assert (T /= null);
+ pragma Assert (T.Buckets /= null);
+
+ begin
+ -- The load factor is the ratio of key-value pairs to buckets
+
+ return Threshold_Type (T.Pairs) / Threshold_Type (T.Buckets'Length);
+ end Load_Factor;
+
+ ----------
+ -- Lock --
+ ----------
+
+ procedure Lock (T : Instance) is
+ begin
+ -- The hash table may be locked multiple times if multiple iterators
+ -- are operating over it.
+
+ T.Locked := T.Locked + 1;
+ end Lock;
+
+ -----------------------
+ -- Mutate_And_Rehash --
+ -----------------------
+
+ procedure Mutate_And_Rehash (T : Instance; Size : Bucket_Range_Type) is
+ procedure Rehash (From : Bucket_Table_Ptr; To : Bucket_Table_Ptr);
+ pragma Inline (Rehash);
+ -- Remove all nodes from buckets From and rehash them into buckets To
+
+ procedure Rehash_Bucket (Head : Node_Ptr; To : Bucket_Table_Ptr);
+ pragma Inline (Rehash_Bucket);
+ -- Detach all nodes starting from dummy head Head and rehash them
+ -- into To.
+
+ procedure Rehash_Node (Nod : Node_Ptr; To : Bucket_Table_Ptr);
+ pragma Inline (Rehash_Node);
+ -- Rehash node Nod into To
+
+ ------------
+ -- Rehash --
+ ------------
+
+ procedure Rehash (From : Bucket_Table_Ptr; To : Bucket_Table_Ptr) is
+ begin
+ pragma Assert (From /= null);
+ pragma Assert (To /= null);
+
+ for Scan_Idx in From'Range loop
+ Rehash_Bucket (From (Scan_Idx)'Access, To);
+ end loop;
+ end Rehash;
+
+ -------------------
+ -- Rehash_Bucket --
+ -------------------
+
+ procedure Rehash_Bucket (Head : Node_Ptr; To : Bucket_Table_Ptr) is
+ pragma Assert (Head /= null);
+
+ Nod : Node_Ptr;
+
+ begin
+ -- Detach all nodes which follow the dummy head
+
+ while Is_Valid (Head.Next, Head) loop
+ Nod := Head.Next;
+
+ Detach (Nod);
+ Rehash_Node (Nod, To);
+ end loop;
+ end Rehash_Bucket;
+
+ -----------------
+ -- Rehash_Node --
+ -----------------
+
+ procedure Rehash_Node (Nod : Node_Ptr; To : Bucket_Table_Ptr) is
+ pragma Assert (Nod /= null);
+
+ Head : Node_Ptr;
+
+ begin
+ -- Obtain the dummy head of the bucket which should house the
+ -- key-value pair.
+
+ Head := Find_Bucket (To, Nod.Key);
+
+ -- Ensure that the dummy head of an empty bucket is circular with
+ -- respect to itself.
+
+ Ensure_Circular (Head);
+
+ -- Prepend the node to the bucket
+
+ Prepend (Nod, Head);
+ end Rehash_Node;
+
+ -- Local declarations
+
+ Old_Bkts : Bucket_Table_Ptr;
+
+ -- Start of processing for Mutate_And_Rehash
+
+ begin
+ pragma Assert (T /= null);
+
+ Old_Bkts := T.Buckets;
+ T.Buckets := new Bucket_Table (0 .. Size - 1);
+
+ -- Transfer and rehash all key-value pairs from the old buckets to
+ -- the new buckets.
+
+ Rehash (From => Old_Bkts, To => T.Buckets);
+ Free (Old_Bkts);
+ end Mutate_And_Rehash;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next (Iter : in out Iterator; Key : out Key_Type) is
+ Is_OK : constant Boolean := Is_Valid (Iter);
+ Saved : constant Node_Ptr := Iter.Nod;
+ T : constant Instance := Iter.Table;
+ Head : Node_Ptr;
+
+ begin
+ pragma Assert (T /= null);
+ pragma Assert (T.Buckets /= null);
+
+ -- The iterator is no longer valid which indicates that it has been
+ -- exhausted. Unlock all mutation functionality of the hash table as
+ -- the iterator cannot be advanced any further.
+
+ if not Is_OK then
+ Unlock (T);
+ raise Iterator_Exhausted;
+ end if;
+
+ -- Advance to the next node along the same bucket
+
+ Iter.Nod := Iter.Nod.Next;
+ Head := T.Buckets (Iter.Idx)'Access;
+
+ -- If the new node is no longer valid, then this indicates that the
+ -- current bucket has been exhausted. Advance to the next valid node
+ -- within the remaining range of buckets. If no such node exists, the
+ -- iterator is left in a state which does not allow it to advance.
+
+ if not Is_Valid (Iter.Nod, Head) then
+ First_Valid_Node
+ (T => T,
+ Low_Bkt => Iter.Idx + 1,
+ High_Bkt => T.Buckets'Last,
+ Idx => Iter.Idx,
+ Nod => Iter.Nod);
+ end if;
+
+ Key := Saved.Key;
+ end Next;
+
+ -------------
+ -- Prepend --
+ -------------
+
+ procedure Prepend (Nod : Node_Ptr; Head : Node_Ptr) is
+ pragma Assert (Nod /= null);
+ pragma Assert (Head /= null);
+
+ Next : constant Node_Ptr := Head.Next;
+
+ begin
+ Head.Next := Nod;
+ Next.Prev := Nod;
+
+ Nod.Next := Next;
+ Nod.Prev := Head;
+ end Prepend;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (T : Instance;
+ Key : Key_Type;
+ Value : Value_Type)
+ is
+ procedure Expand;
+ pragma Inline (Expand);
+ -- Determine whether hash table T requires expansion, and if so,
+ -- double its size.
+
+ procedure Prepend_Or_Replace (Head : Node_Ptr);
+ pragma Inline (Prepend_Or_Replace);
+ -- Update the value of a node within a bucket with dummy head Head
+ -- whose key is Key to Value. If there is no such node, prepend a new
+ -- key-value pair to the bucket.
+
+ ------------
+ -- Expand --
+ ------------
+
+ procedure Expand is
+ pragma Assert (T /= null);
+ pragma Assert (T.Buckets /= null);
+
+ Old_Size : constant Bucket_Range_Type := T.Buckets'Length;
+
+ begin
+ -- The ratio of pairs to buckets is over the desited threshold.
+ -- Expand the hash table only when there is still room to do so.
+
+ if Load_Factor (T) > Expansion_Threshold
+ and then Old_Size <= Safe_Expansion_Size
+ then
+ Mutate_And_Rehash (T, Old_Size * Expansion_Factor);
+ end if;
+ end Expand;
+
+ ------------------------
+ -- Prepend_Or_Replace --
+ ------------------------
+
+ procedure Prepend_Or_Replace (Head : Node_Ptr) is
+ pragma Assert (Head /= null);
+
+ Nod : Node_Ptr;
+
+ begin
+ -- If the bucket containst at least one valid node, then there is
+ -- a chance that a node with the same key as Key exists. If this
+ -- is the case, the value of that node must be updated.
+
+ Nod := Head.Next;
+ while Is_Valid (Nod, Head) loop
+ if Equivalent_Keys (Nod.Key, Key) then
+ Nod.Value := Value;
+ return;
+ end if;
+
+ Nod := Nod.Next;
+ end loop;
+
+ -- At this point the bucket is either empty, or none of the nodes
+ -- match key Key. Prepend a new key-value pair.
+
+ Nod := new Node'(Key, Value, null, null);
+
+ Prepend (Nod, Head);
+ end Prepend_Or_Replace;
+
+ -- Local variables
+
+ Head : Node_Ptr;
+
+ -- Start of processing for Put
+
+ begin
+ Ensure_Created (T);
+ Ensure_Unlocked (T);
+
+ -- Obtain the dummy head of the bucket which should house the
+ -- key-value pair.
+
+ Head := Find_Bucket (T.Buckets, Key);
+
+ -- Ensure that the dummy head of an empty bucket is circular with
+ -- respect to itself.
+
+ Ensure_Circular (Head);
+
+ -- In case the bucket already contains a node with the same key,
+ -- replace its value, otherwise prepend a new key-value pair.
+
+ Prepend_Or_Replace (Head);
+
+ T.Pairs := T.Pairs + 1;
+
+ -- Expand the hash table if the ratio of pairs to buckets goes over
+ -- Expansion_Threshold.
+
+ Expand;
+ end Put;
+
+ -----------
+ -- Reset --
+ -----------
+
+ procedure Reset (T : Instance) is
+ begin
+ Ensure_Created (T);
+ Ensure_Unlocked (T);
+
+ -- Destroy all nodes in all buckets
+
+ Destroy_Buckets (T.Buckets);
+ Free (T.Buckets);
+
+ -- Recreate the buckets using the original size from creation time
+
+ T.Buckets := new Bucket_Table (0 .. T.Initial_Size - 1);
+ T.Pairs := 0;
+ end Reset;
+
+ ----------
+ -- Size --
+ ----------
+
+ function Size (T : Instance) return Pair_Count_Type is
+ begin
+ Ensure_Created (T);
+
+ return T.Pairs;
+ end Size;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (T : Instance) is
+ begin
+ -- The hash table may be locked multiple times if multiple iterators
+ -- are operating over it.
+
+ T.Locked := T.Locked - 1;
+ end Unlock;
+ end Dynamic_HTable;
+
end GNAT.Dynamic_HTables;
-- Hash table searching routines
--- This package contains three separate packages. The Simple_HTable package
+-- This package contains two separate packages. The Simple_HTable package
-- provides a very simple abstraction that associates one element to one key
-- value and takes care of all allocations automatically using the heap. The
-- Static_HTable package provides a more complex interface that allows full
--- control over allocation. The Load_Factor_HTable package provides a more
--- complex abstraction where collisions are resolved by chaining, and the
--- table grows by a percentage after the load factor has been exceeded.
+-- control over allocation.
-- This package provides a facility similar to that of GNAT.HTable, except
-- that this package declares types that can be used to define dynamic
-- GNAT.HTable to keep as much coherency as possible between these two
-- related units.
+pragma Compiler_Unit_Warning;
+
package GNAT.Dynamic_HTables is
-------------------
Null_Ptr : Elmt_Ptr;
-- The null value of the Elmt_Ptr type
+ with function Next (E : Elmt_Ptr) return Elmt_Ptr;
with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
- with function Next (E : Elmt_Ptr) return Elmt_Ptr;
-- The type must provide an internal link for the sake of the
-- staticness of the HTable.
type Key is limited private;
with function Get_Key (E : Elmt_Ptr) return Key;
- with function Hash (F : Key) return Header_Num;
- with function Equal (F1, F2 : Key) return Boolean;
+ with function Hash (F : Key) return Header_Num;
+ with function Equal (F1 : Key; F2 : Key) return Boolean;
package Static_HTable is
-
type Instance is private;
Nil : constant Instance;
procedure Reset (T : in out Instance);
- -- Resets the hash table by releasing all memory associated with
- -- it. The hash table can safely be reused after this call. For the
- -- most common case where Elmt_Ptr is an access type, and Null_Ptr is
- -- null, this is only needed if the same table is reused in a new
- -- context. If Elmt_Ptr is other than an access type, or Null_Ptr is
- -- other than null, then Reset must be called before the first use of
- -- the hash table.
+ -- Resets the hash table by releasing all memory associated with it. The
+ -- hash table can safely be reused after this call. For the most common
+ -- case where Elmt_Ptr is an access type, and Null_Ptr is null, this is
+ -- only needed if the same table is reused in a new context. If Elmt_Ptr
+ -- is other than an access type, or Null_Ptr is other than null, then
+ -- Reset must be called before the first use of the hash table.
procedure Set (T : in out Instance; E : Elmt_Ptr);
-- Insert the element pointer in the HTable
function Get (T : Instance; K : Key) return Elmt_Ptr;
- -- Returns the latest inserted element pointer with the given Key
- -- or null if none.
+ -- Returns the latest inserted element pointer with the given Key or
+ -- null if none.
procedure Remove (T : Instance; K : Key);
- -- Removes the latest inserted element pointer associated with the
- -- given key if any, does nothing if none.
+ -- Removes the latest inserted element pointer associated with the given
+ -- key if any, does nothing if none.
function Get_First (T : Instance) return Elmt_Ptr;
-- Returns Null_Ptr if the Htable is empty, otherwise returns one
-- function will return the same element.
function Get_Next (T : Instance) return Elmt_Ptr;
- -- Returns an unspecified element that has not been returned by the
- -- same function since the last call to Get_First or Null_Ptr if
- -- there is no such element or Get_First has never been called. If
- -- there is no call to 'Set' in between Get_Next calls, all the
- -- elements of the Htable will be traversed.
+ -- Returns an unspecified element that has not been returned by the same
+ -- function since the last call to Get_First or Null_Ptr if there is no
+ -- such element or Get_First has never been called. If there is no call
+ -- to 'Set' in between Get_Next calls, all the elements of the Htable
+ -- will be traversed.
private
type Table_Type is array (Header_Num) of Elmt_Ptr;
-- a given key
type Key is private;
- with function Hash (F : Key) return Header_Num;
- with function Equal (F1, F2 : Key) return Boolean;
+ with function Hash (F : Key) return Header_Num;
+ with function Equal (F1 : Key; F2 : Key) return Boolean;
package Simple_HTable is
-
type Instance is private;
Nil : constant Instance;
-- same restrictions apply as Get_Next.
private
-
type Element_Wrapper;
type Elmt_Ptr is access all Element_Wrapper;
type Element_Wrapper is record
type Instance is new Tab.Instance;
Nil : constant Instance := Instance (Tab.Nil);
-
end Simple_HTable;
+ --------------------
+ -- Dynamic_HTable --
+ --------------------
+
+ -- The following package offers a hash table abstraction with the following
+ -- characteristics:
+ --
+ -- * Dynamic resizing based on load factor.
+ -- * Creation of multiple instances, of different sizes.
+ -- * Iterable keys.
+ --
+ -- This type of hash table is best used in scenarios where the size of the
+ -- key set is not known. The dynamic resizing aspect allows for performance
+ -- to remain within reasonable bounds as the size of the key set grows.
+ --
+ -- The following use pattern must be employed when operating this table:
+ --
+ -- Table : Instance := Create (<some size>);
+ --
+ -- <various operations>
+ --
+ -- Destroy (Table);
+ --
+ -- The destruction of the table reclaims all storage occupied by it.
+
+ -- The following type denotes the underlying range of the hash table
+ -- buckets.
+
+ type Bucket_Range_Type is mod 2 ** 32;
+
+ -- The following type denotes the multiplicative factor used in expansion
+ -- and compression of the hash table.
+
+ subtype Factor_Type is Bucket_Range_Type range 2 .. 100;
+
+ -- The following type denotes the number of key-value pairs stored in the
+ -- hash table.
+
+ type Pair_Count_Type is range 0 .. 2 ** 31 - 1;
+
+ -- The following type denotes the threshold range used in expansion and
+ -- compression of the hash table.
+
+ subtype Threshold_Type is Long_Float range 0.0 .. Long_Float'Last;
+
+ generic
+ type Key_Type is private;
+ type Value_Type is private;
+ -- The types of the key-value pairs stored in the hash table
+
+ No_Value : Value_Type;
+ -- An indicator for a non-existent value
+
+ Expansion_Threshold : Threshold_Type;
+ Expansion_Factor : Factor_Type;
+ -- Once the load factor goes over Expansion_Threshold, the size of the
+ -- buckets is increased using the formula
+ --
+ -- New_Size = Old_Size * Expansion_Factor
+ --
+ -- An Expansion_Threshold of 1.5 and Expansion_Factor of 2 indicate that
+ -- the size of the buckets will be doubled once the load factor exceeds
+ -- 1.5.
+
+ Compression_Threshold : Threshold_Type;
+ Compression_Factor : Factor_Type;
+ -- Once the load factor drops below Compression_Threshold, the size of
+ -- the buckets is decreased using the formula
+ --
+ -- New_Size = Old_Size / Compression_Factor
+ --
+ -- A Compression_Threshold of 0.5 and Compression_Factor of 2 indicate
+ -- that the size of the buckets will be halved once the load factor
+ -- drops below 0.5.
+
+ with function Equivalent_Keys
+ (Left : Key_Type;
+ Right : Key_Type) return Boolean;
+ -- Determine whether two keys are equivalent
+
+ with function Hash (Key : Key_Type) return Bucket_Range_Type;
+ -- Map an arbitrary key into the range of buckets
+
+ package Dynamic_HTable is
+
+ ----------------------
+ -- Table operations --
+ ----------------------
+
+ -- The following type denotes a hash table handle. Each instance must be
+ -- created using routine Create.
+
+ type Instance is private;
+ Nil : constant Instance;
+
+ Not_Created : exception;
+ -- This exception is raised when the hash table has not been created by
+ -- routine Create, and an attempt is made to read or mutate its state.
+
+ Table_Locked : exception;
+ -- This exception is raised when the hash table is being iterated on,
+ -- and an attempt is made to mutate its state.
+
+ function Create (Initial_Size : Bucket_Range_Type) return Instance;
+ -- Create a new table with bucket capacity Initial_Size. This routine
+ -- must be called at the start of a hash table's lifetime.
+
+ procedure Delete (T : Instance; Key : Key_Type);
+ -- Delete the value which corresponds to key Key from hash table T. The
+ -- routine has no effect if the value is not present in the hash table.
+ -- This action will raise Table_Locked if the hash table has outstanding
+ -- iterators. If the load factor drops below Compression_Threshold, the
+ -- size of the buckets is decreased by Copression_Factor.
+
+ procedure Destroy (T : in out Instance);
+ -- Destroy the contents of hash table T, rendering it unusable. This
+ -- routine must be called at the end of a hash table's lifetime. This
+ -- action will raise Table_Locked if the hash table has outstanding
+ -- iterators.
+
+ function Get (T : Instance; Key : Key_Type) return Value_Type;
+ -- Obtain the value which corresponds to key Key from hash table T. If
+ -- the value does not exist, return No_Value.
+
+ procedure Put
+ (T : Instance;
+ Key : Key_Type;
+ Value : Value_Type);
+ -- Associate value Value with key Key in hash table T. If the table
+ -- already contains a mapping of the same key to a previous value, the
+ -- previous value is overwritten. This action will raise Table_Locked
+ -- if the hash table has outstanding iterators. If the load factor goes
+ -- over Expansion_Threshold, the size of the buckets is increased by
+ -- Expansion_Factor.
+
+ procedure Reset (T : Instance);
+ -- Destroy the contents of hash table T, and reset it to its initial
+ -- created state. This action will raise Table_Locked if the hash table
+ -- has outstanding iterators.
+
+ function Size (T : Instance) return Pair_Count_Type;
+ -- Obtain the number of key-value pairs in hash table T
+
+ -------------------------
+ -- Iterator operations --
+ -------------------------
+
+ -- The following type represents a key iterator. An iterator locks
+ -- all mutation operations, and unlocks them once it is exhausted.
+ -- The iterator must be used with the following pattern:
+ --
+ -- Iter := Iterate (My_Table);
+ -- while Has_Next (Iter) loop
+ -- Key := Next (Iter);
+ -- . . .
+ -- end loop;
+ --
+ -- It is possible to advance the iterator by using Next only, however
+ -- this risks raising Iterator_Exhausted.
+
+ type Iterator is private;
+
+ Iterator_Exhausted : exception;
+ -- This exception is raised when an iterator is exhausted and further
+ -- attempts to advance it are made by calling routine Next.
+
+ function Iterate (T : Instance) return Iterator;
+ -- Obtain an iterator over the keys of hash table T. This action locks
+ -- all mutation functionality of the associated hash table.
+
+ function Has_Next (Iter : Iterator) return Boolean;
+ -- Determine whether iterator Iter has more keys to examine. If the
+ -- iterator has been exhausted, restore all mutation functionality of
+ -- the associated hash table.
+
+ procedure Next
+ (Iter : in out Iterator;
+ Key : out Key_Type);
+ -- Return the current key referenced by iterator Iter and advance to
+ -- the next available key. If the iterator has been exhausted and
+ -- further attempts are made to advance it, this routine restores
+ -- mutation functionality of the associated hash table, and then
+ -- raises Iterator_Exhausted.
+
+ private
+ -- The following type represents a doubly linked list node used to
+ -- store a key-value pair. There are several reasons to use a doubly
+ -- linked list:
+ --
+ -- * Most read and write operations utilize the same primitve
+ -- routines to locate, create, and delete a node, allowing for
+ -- greater degree of code sharing.
+ --
+ -- * Special cases are eliminated by maintaining a circular node
+ -- list with a dummy head (see type Bucket_Table).
+ --
+ -- A node is said to be "valid" if it is non-null, and does not refer to
+ -- the dummy head of some bucket.
+
+ type Node;
+ type Node_Ptr is access all Node;
+ type Node is record
+ Key : Key_Type;
+ Value : Value_Type := No_Value;
+ -- Key-value pair stored in a bucket
+
+ Prev : Node_Ptr := null;
+ Next : Node_Ptr := null;
+ end record;
+
+ -- The following type represents a bucket table. Each bucket contains a
+ -- circular doubly linked list of nodes with a dummy head. Initially,
+ -- the head does not refer to itself. This is intentional because it
+ -- improves the performance of creation, compression, and expansion by
+ -- avoiding a separate pass to link a head to itself. Several routines
+ -- ensure that the head is properly formed.
+
+ type Bucket_Table is array (Bucket_Range_Type range <>) of aliased Node;
+ type Bucket_Table_Ptr is access Bucket_Table;
+
+ -- The following type represents a hash table
+
+ type Hash_Table is record
+ Buckets : Bucket_Table_Ptr := null;
+ -- Reference to the compressing / expanding buckets
+
+ Initial_Size : Bucket_Range_Type := 0;
+ -- The initial size of the buckets as specified at creation time
+
+ Locked : Natural := 0;
+ -- Number of outstanding iterators
+
+ Pairs : Pair_Count_Type := 0;
+ -- Number of key-value pairs in the buckets
+ end record;
+
+ type Instance is access Hash_Table;
+ Nil : constant Instance := null;
+
+ -- The following type represents a key iterator
+
+ type Iterator is record
+ Idx : Bucket_Range_Type := 0;
+ -- Index of the current bucket being examined. This index is always
+ -- kept within the range of the buckets.
+
+ Nod : Node_Ptr := null;
+ -- Reference to the current node being examined within the current
+ -- bucket. The invariant of the iterator requires that this field
+ -- always point to a valid node. A value of null indicates that the
+ -- iterator is exhausted.
+
+ Table : Instance := null;
+ -- Reference to the associated hash table
+ end record;
+ end Dynamic_HTable;
+
end GNAT.Dynamic_HTables;
+2018-08-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * gnat.dg/dynhash.adb: New testcase.
+
2018-08-21 Javier Miranda <miranda@adacore.com>
* gnat.dg/enum4.adb: New testcase.
--- /dev/null
+-- { dg-do run }
+
+with Ada.Text_IO; use Ada.Text_IO;
+with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
+
+procedure Dynhash is
+ function Hash (Key : Integer) return Bucket_Range_Type;
+
+ package DHT is new Dynamic_HTable
+ (Key_Type => Integer,
+ Value_Type => Integer,
+ No_Value => 0,
+ Expansion_Threshold => 1.3,
+ Expansion_Factor => 2,
+ Compression_Threshold => 0.3,
+ Compression_Factor => 2,
+ Equivalent_Keys => "=",
+ Hash => Hash);
+ use DHT;
+
+ function Create_And_Populate
+ (Low_Key : Integer;
+ High_Key : Integer;
+ Init_Size : Bucket_Range_Type) return Instance;
+ -- Create a hash table with initial size Init_Size and populate it with
+ -- key-value pairs where both keys and values are in the range Low_Key
+ -- .. High_Key.
+
+ procedure Check_Empty
+ (Caller : String;
+ T : Instance;
+ Low_Key : Integer;
+ High_Key : Integer);
+ -- Ensure that
+ --
+ -- * The key-value pairs count of hash table T is 0.
+ -- * All values for the keys in range Low_Key .. High_Key are 0.
+
+ procedure Check_Keys
+ (Caller : String;
+ Iter : in out Iterator;
+ Low_Key : Integer;
+ High_Key : Integer);
+ -- Ensure that iterator Iter visits every key in the range Low_Key ..
+ -- High_Key exactly once.
+
+ procedure Check_Locked_Mutations (Caller : String; T : in out Instance);
+ -- Ensure that all mutation operations of hash table T are locked
+
+ procedure Check_Size
+ (Caller : String;
+ T : Instance;
+ Exp_Count : Pair_Count_Type);
+ -- Ensure that the count of key-value pairs of hash table T matches
+ -- expected count Exp_Count. Emit an error if this is not the case.
+
+ procedure Test_Create (Init_Size : Bucket_Range_Type);
+ -- Verify that all dynamic hash table operations fail on a non-created
+ -- table of size Init_Size.
+
+ procedure Test_Delete_Get_Put_Size
+ (Low_Key : Integer;
+ High_Key : Integer;
+ Exp_Count : Pair_Count_Type;
+ Init_Size : Bucket_Range_Type);
+ -- Verify that
+ --
+ -- * Put properly inserts values in the hash table.
+ -- * Get properly retrieves all values inserted in the table.
+ -- * Delete properly deletes values.
+ -- * The size of the hash table properly reflects the number of key-value
+ -- pairs.
+ --
+ -- Low_Key and High_Key denote the range of keys to be inserted, retrieved,
+ -- and deleted. Exp_Count is the expected count of key-value pairs n the
+ -- hash table. Init_Size denotes the initial size of the table.
+
+ procedure Test_Iterate
+ (Low_Key : Integer;
+ High_Key : Integer;
+ Init_Size : Bucket_Range_Type);
+ -- Verify that iterators
+ --
+ -- * Properly visit each key exactly once.
+ -- * Mutation operations are properly locked and unlocked during
+ -- iteration.
+ --
+ -- Low_Key and High_Key denote the range of keys to be inserted, retrieved,
+ -- and deleted. Init_Size denotes the initial size of the table.
+
+ procedure Test_Iterate_Empty (Init_Size : Bucket_Range_Type);
+ -- Verify that an iterator over an empty hash table
+ --
+ -- * Does not visit any key
+ -- * Mutation operations are properly locked and unlocked during
+ -- iteration.
+ --
+ -- Init_Size denotes the initial size of the table.
+
+ procedure Test_Iterate_Forced
+ (Low_Key : Integer;
+ High_Key : Integer;
+ Init_Size : Bucket_Range_Type);
+ -- Verify that an iterator that is forcefully advanced by just Next
+ --
+ -- * Properly visit each key exactly once.
+ -- * Mutation operations are properly locked and unlocked during
+ -- iteration.
+ --
+ -- Low_Key and High_Key denote the range of keys to be inserted, retrieved,
+ -- and deleted. Init_Size denotes the initial size of the table.
+
+ procedure Test_Replace
+ (Low_Val : Integer;
+ High_Val : Integer;
+ Init_Size : Bucket_Range_Type);
+ -- Verify that Put properly updates the value of a particular key. Low_Val
+ -- and High_Val denote the range of values to be updated. Init_Size denotes
+ -- the initial size of the table.
+
+ procedure Test_Reset
+ (Low_Key : Integer;
+ High_Key : Integer;
+ Init_Size : Bucket_Range_Type);
+ -- Verify that Reset properly destroy and recreats a hash table. Low_Key
+ -- and High_Key denote the range of keys to be inserted in the hash table.
+ -- Init_Size denotes the initial size of the table.
+
+ -------------------------
+ -- Create_And_Populate --
+ -------------------------
+
+ function Create_And_Populate
+ (Low_Key : Integer;
+ High_Key : Integer;
+ Init_Size : Bucket_Range_Type) return Instance
+ is
+ T : Instance;
+
+ begin
+ T := Create (Init_Size);
+
+ for Key in Low_Key .. High_Key loop
+ Put (T, Key, Key);
+ end loop;
+
+ return T;
+ end Create_And_Populate;
+
+ -----------------
+ -- Check_Empty --
+ -----------------
+
+ procedure Check_Empty
+ (Caller : String;
+ T : Instance;
+ Low_Key : Integer;
+ High_Key : Integer)
+ is
+ Val : Integer;
+
+ begin
+ Check_Size
+ (Caller => Caller,
+ T => T,
+ Exp_Count => 0);
+
+ for Key in Low_Key .. High_Key loop
+ Val := Get (T, Key);
+
+ if Val /= 0 then
+ Put_Line ("ERROR: " & Caller & ": wrong value");
+ Put_Line ("expected: 0");
+ Put_Line ("got :" & Val'Img);
+ end if;
+ end loop;
+ end Check_Empty;
+
+ ----------------
+ -- Check_Keys --
+ ----------------
+
+ procedure Check_Keys
+ (Caller : String;
+ Iter : in out Iterator;
+ Low_Key : Integer;
+ High_Key : Integer)
+ is
+ type Bit_Vector is array (Low_Key .. High_Key) of Boolean;
+ pragma Pack (Bit_Vector);
+
+ Count : Natural;
+ Key : Integer;
+ Seen : Bit_Vector := (others => False);
+
+ begin
+ -- Compute the number of outstanding keys that have to be iterated on
+
+ Count := High_Key - Low_Key + 1;
+
+ while Has_Next (Iter) loop
+ Next (Iter, Key);
+
+ if Seen (Key) then
+ Put_Line
+ ("ERROR: " & Caller & ": Check_Keys: duplicate key" & Key'Img);
+ else
+ Seen (Key) := True;
+ Count := Count - 1;
+ end if;
+ end loop;
+
+ -- In the end, all keys must have been iterated on
+
+ if Count /= 0 then
+ for Key in Seen'Range loop
+ if not Seen (Key) then
+ Put_Line
+ ("ERROR: " & Caller & ": Check_Keys: missing key" & Key'Img);
+ end if;
+ end loop;
+ end if;
+ end Check_Keys;
+
+ ----------------------------
+ -- Check_Locked_Mutations --
+ ----------------------------
+
+ procedure Check_Locked_Mutations (Caller : String; T : in out Instance) is
+ begin
+ begin
+ Delete (T, 1);
+ Put_Line ("ERROR: " & Caller & ": Delete: no exception raised");
+ exception
+ when Table_Locked =>
+ null;
+ when others =>
+ Put_Line ("ERROR: " & Caller & ": Delete: unexpected exception");
+ end;
+
+ begin
+ Destroy (T);
+ Put_Line ("ERROR: " & Caller & ": Destroy: no exception raised");
+ exception
+ when Table_Locked =>
+ null;
+ when others =>
+ Put_Line ("ERROR: " & Caller & ": Destroy: unexpected exception");
+ end;
+
+ begin
+ Put (T, 1, 1);
+ Put_Line ("ERROR: " & Caller & ": Put: no exception raised");
+ exception
+ when Table_Locked =>
+ null;
+ when others =>
+ Put_Line ("ERROR: " & Caller & ": Put: unexpected exception");
+ end;
+
+ begin
+ Reset (T);
+ Put_Line ("ERROR: " & Caller & ": Reset: no exception raised");
+ exception
+ when Table_Locked =>
+ null;
+ when others =>
+ Put_Line ("ERROR: " & Caller & ": Reset: unexpected exception");
+ end;
+ end Check_Locked_Mutations;
+
+ ----------------
+ -- Check_Size --
+ ----------------
+
+ procedure Check_Size
+ (Caller : String;
+ T : Instance;
+ Exp_Count : Pair_Count_Type)
+ is
+ Count : constant Pair_Count_Type := Size (T);
+
+ begin
+ if Count /= Exp_Count then
+ Put_Line ("ERROR: " & Caller & ": Size: wrong value");
+ Put_Line ("expected:" & Exp_Count'Img);
+ Put_Line ("got :" & Count'Img);
+ end if;
+ end Check_Size;
+
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (Key : Integer) return Bucket_Range_Type is
+ begin
+ return Bucket_Range_Type (Key);
+ end Hash;
+
+ -----------------
+ -- Test_Create --
+ -----------------
+
+ procedure Test_Create (Init_Size : Bucket_Range_Type) is
+ Count : Pair_Count_Type;
+ Iter : Iterator;
+ T : Instance;
+ Val : Integer;
+
+ begin
+ -- Ensure that every routine defined in the API fails on a hash table
+ -- which has not been created yet.
+
+ begin
+ Delete (T, 1);
+ Put_Line ("ERROR: Test_Create: Delete: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Delete: unexpected exception");
+ end;
+
+ begin
+ Destroy (T);
+ Put_Line ("ERROR: Test_Create: Destroy: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Destroy: unexpected exception");
+ end;
+
+ begin
+ Val := Get (T, 1);
+ Put_Line ("ERROR: Test_Create: Get: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Get: unexpected exception");
+ end;
+
+ begin
+ Iter := Iterate (T);
+ Put_Line ("ERROR: Test_Create: Iterate: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Iterate: unexpected exception");
+ end;
+
+ begin
+ Put (T, 1, 1);
+ Put_Line ("ERROR: Test_Create: Put: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Put: unexpected exception");
+ end;
+
+ begin
+ Reset (T);
+ Put_Line ("ERROR: Test_Create: Reset: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Reset: unexpected exception");
+ end;
+
+ begin
+ Count := Size (T);
+ Put_Line ("ERROR: Test_Create: Size: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Size: unexpected exception");
+ end;
+
+ -- Test create
+
+ T := Create (Init_Size);
+
+ -- Clean up the hash table to prevent memory leaks
+
+ Destroy (T);
+ end Test_Create;
+
+ ------------------------------
+ -- Test_Delete_Get_Put_Size --
+ ------------------------------
+
+ procedure Test_Delete_Get_Put_Size
+ (Low_Key : Integer;
+ High_Key : Integer;
+ Exp_Count : Pair_Count_Type;
+ Init_Size : Bucket_Range_Type)
+ is
+ Exp_Val : Integer;
+ T : Instance;
+ Val : Integer;
+
+ begin
+ T := Create_And_Populate (Low_Key, High_Key, Init_Size);
+
+ -- Ensure that its size matches an expected value
+
+ Check_Size
+ (Caller => "Test_Delete_Get_Put_Size",
+ T => T,
+ Exp_Count => Exp_Count);
+
+ -- Ensure that every value for the range of keys exists
+
+ for Key in Low_Key .. High_Key loop
+ Val := Get (T, Key);
+
+ if Val /= Key then
+ Put_Line ("ERROR: Test_Delete_Get_Put_Size: Get: wrong value");
+ Put_Line ("expected:" & Key'Img);
+ Put_Line ("got :" & Val'Img);
+ end if;
+ end loop;
+
+ -- Delete values whose keys are divisible by 10
+
+ for Key in Low_Key .. High_Key loop
+ if Key mod 10 = 0 then
+ Delete (T, Key);
+ end if;
+ end loop;
+
+ -- Ensure that all values whose keys were not deleted still exist
+
+ for Key in Low_Key .. High_Key loop
+ if Key mod 10 = 0 then
+ Exp_Val := 0;
+ else
+ Exp_Val := Key;
+ end if;
+
+ Val := Get (T, Key);
+
+ if Val /= Exp_Val then
+ Put_Line ("ERROR: Test_Delete_Get_Put_Size: Get: wrong value");
+ Put_Line ("expected:" & Exp_Val'Img);
+ Put_Line ("got :" & Val'Img);
+ end if;
+ end loop;
+
+ -- Delete all values
+
+ for Key in Low_Key .. High_Key loop
+ Delete (T, Key);
+ end loop;
+
+ -- Ensure that the hash table is empty
+
+ Check_Empty
+ (Caller => "Test_Delete_Get_Put_Size",
+ T => T,
+ Low_Key => Low_Key,
+ High_Key => High_Key);
+
+ -- Clean up the hash table to prevent memory leaks
+
+ Destroy (T);
+ end Test_Delete_Get_Put_Size;
+
+ ------------------
+ -- Test_Iterate --
+ ------------------
+
+ procedure Test_Iterate
+ (Low_Key : Integer;
+ High_Key : Integer;
+ Init_Size : Bucket_Range_Type)
+ is
+ Iter_1 : Iterator;
+ Iter_2 : Iterator;
+ T : Instance;
+
+ begin
+ T := Create_And_Populate (Low_Key, High_Key, Init_Size);
+
+ -- Obtain an iterator. This action must lock all mutation operations of
+ -- the hash table.
+
+ Iter_1 := Iterate (T);
+
+ -- Ensure that every mutation routine defined in the API fails on a hash
+ -- table with at least one outstanding iterator.
+
+ Check_Locked_Mutations
+ (Caller => "Test_Iterate",
+ T => T);
+
+ -- Obtain another iterator
+
+ Iter_2 := Iterate (T);
+
+ -- Ensure that every mutation is still locked
+
+ Check_Locked_Mutations
+ (Caller => "Test_Iterate",
+ T => T);
+
+ -- Ensure that all keys are iterable. Note that this does not unlock the
+ -- mutation operations of the hash table because Iter_2 is not exhausted
+ -- yet.
+
+ Check_Keys
+ (Caller => "Test_Iterate",
+ Iter => Iter_1,
+ Low_Key => Low_Key,
+ High_Key => High_Key);
+
+ Check_Locked_Mutations
+ (Caller => "Test_Iterate",
+ T => T);
+
+ -- Ensure that all keys are iterable. This action unlocks all mutation
+ -- operations of the hash table because all outstanding iterators have
+ -- been exhausted.
+
+ Check_Keys
+ (Caller => "Test_Iterate",
+ Iter => Iter_2,
+ Low_Key => Low_Key,
+ High_Key => High_Key);
+
+ -- Ensure that all mutation operations are once again callable
+
+ Delete (T, Low_Key);
+ Put (T, Low_Key, Low_Key);
+ Reset (T);
+
+ -- Clean up the hash table to prevent memory leaks
+
+ Destroy (T);
+ end Test_Iterate;
+
+ ------------------------
+ -- Test_Iterate_Empty --
+ ------------------------
+
+ procedure Test_Iterate_Empty (Init_Size : Bucket_Range_Type) is
+ Iter : Iterator;
+ Key : Integer;
+ T : Instance;
+
+ begin
+ T := Create_And_Populate (0, -1, Init_Size);
+
+ -- Obtain an iterator. This action must lock all mutation operations of
+ -- the hash table.
+
+ Iter := Iterate (T);
+
+ -- Ensure that every mutation routine defined in the API fails on a hash
+ -- table with at least one outstanding iterator.
+
+ Check_Locked_Mutations
+ (Caller => "Test_Iterate_Empty",
+ T => T);
+
+ -- Attempt to iterate over the keys
+
+ while Has_Next (Iter) loop
+ Next (Iter, Key);
+
+ Put_Line ("ERROR: Test_Iterate_Empty: key" & Key'Img & " exists");
+ end loop;
+
+ -- Ensure that all mutation operations are once again callable
+
+ Delete (T, 1);
+ Put (T, 1, 1);
+ Reset (T);
+
+ -- Clean up the hash table to prevent memory leaks
+
+ Destroy (T);
+ end Test_Iterate_Empty;
+
+ -------------------------
+ -- Test_Iterate_Forced --
+ -------------------------
+
+ procedure Test_Iterate_Forced
+ (Low_Key : Integer;
+ High_Key : Integer;
+ Init_Size : Bucket_Range_Type)
+ is
+ Iter : Iterator;
+ Key : Integer;
+ T : Instance;
+
+ begin
+ T := Create_And_Populate (Low_Key, High_Key, Init_Size);
+
+ -- Obtain an iterator. This action must lock all mutation operations of
+ -- the hash table.
+
+ Iter := Iterate (T);
+
+ -- Ensure that every mutation routine defined in the API fails on a hash
+ -- table with at least one outstanding iterator.
+
+ Check_Locked_Mutations
+ (Caller => "Test_Iterate_Forced",
+ T => T);
+
+ -- Forcibly advance the iterator until it raises an exception
+
+ begin
+ for Guard in Low_Key .. High_Key + 1 loop
+ Next (Iter, Key);
+ end loop;
+
+ Put_Line
+ ("ERROR: Test_Iterate_Forced: Iterator_Exhausted not raised");
+ exception
+ when Iterator_Exhausted =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Iterate_Forced: unexpected exception");
+ end;
+
+ -- Ensure that all mutation operations are once again callable
+
+ Delete (T, Low_Key);
+ Put (T, Low_Key, Low_Key);
+ Reset (T);
+
+ -- Clean up the hash table to prevent memory leaks
+
+ Destroy (T);
+ end Test_Iterate_Forced;
+
+ ------------------
+ -- Test_Replace --
+ ------------------
+
+ procedure Test_Replace
+ (Low_Val : Integer;
+ High_Val : Integer;
+ Init_Size : Bucket_Range_Type)
+ is
+ Key : constant Integer := 1;
+ T : Instance;
+ Val : Integer;
+
+ begin
+ T := Create (Init_Size);
+
+ -- Ensure the Put properly updates values with the same key
+
+ for Exp_Val in Low_Val .. High_Val loop
+ Put (T, Key, Exp_Val);
+
+ Val := Get (T, Key);
+
+ if Val /= Exp_Val then
+ Put_Line ("ERROR: Test_Replace: Get: wrong value");
+ Put_Line ("expected:" & Exp_Val'Img);
+ Put_Line ("got :" & Val'Img);
+ end if;
+ end loop;
+
+ -- Clean up the hash table to prevent memory leaks
+
+ Destroy (T);
+ end Test_Replace;
+
+ ----------------
+ -- Test_Reset --
+ ----------------
+
+ procedure Test_Reset
+ (Low_Key : Integer;
+ High_Key : Integer;
+ Init_Size : Bucket_Range_Type)
+ is
+ T : Instance;
+
+ begin
+ T := Create_And_Populate (Low_Key, High_Key, Init_Size);
+
+ -- Reset the contents of the hash table
+
+ Reset (T);
+
+ -- Ensure that the hash table is empty
+
+ Check_Empty
+ (Caller => "Test_Reset",
+ T => T,
+ Low_Key => Low_Key,
+ High_Key => High_Key);
+
+ -- Clean up the hash table to prevent memory leaks
+
+ Destroy (T);
+ end Test_Reset;
+
+-- Start of processing for Operations
+
+begin
+ Test_Create (Init_Size => 1);
+ Test_Create (Init_Size => 100);
+
+ Test_Delete_Get_Put_Size
+ (Low_Key => 1,
+ High_Key => 1,
+ Exp_Count => 1,
+ Init_Size => 1);
+
+ Test_Delete_Get_Put_Size
+ (Low_Key => 1,
+ High_Key => 1000,
+ Exp_Count => 1000,
+ Init_Size => 32);
+
+ Test_Iterate
+ (Low_Key => 1,
+ High_Key => 32,
+ Init_Size => 32);
+
+ Test_Iterate_Empty (Init_Size => 32);
+
+ Test_Iterate_Forced
+ (Low_Key => 1,
+ High_Key => 32,
+ Init_Size => 32);
+
+ Test_Replace
+ (Low_Val => 1,
+ High_Val => 10,
+ Init_Size => 32);
+
+ Test_Reset
+ (Low_Key => 1,
+ High_Key => 1000,
+ Init_Size => 100);
+end Dynhash;
projects / gcc.git / commitdiff