diff options
author | Hristian Kirtchev <kirtchev@adacore.com> | 2018-08-21 14:44:41 +0000 |
---|---|---|
committer | Pierre-Marie de Rodat <pmderodat@gcc.gnu.org> | 2018-08-21 14:44:41 +0000 |
commit | d8251d001b3507ffb80b26f4d17f1daa99a5dc4a (patch) | |
tree | 7c67c739e2cc9d5d9580bff4999fa3d7cd340002 | |
parent | f20b5ef46d7338e626286721a74e3fd3385e8be0 (diff) | |
download | gcc-d8251d001b3507ffb80b26f4d17f1daa99a5dc4a.zip gcc-d8251d001b3507ffb80b26f4d17f1daa99a5dc4a.tar.gz gcc-d8251d001b3507ffb80b26f4d17f1daa99a5dc4a.tar.bz2 |
[Ada] Dynamically resizable, load factor-based hash table
This patch introduces a dynamically resizable, load factor-based hash
table in unit GNAT.Dynamic_HTables.
2018-08-21 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* libgnat/g-dynhta.adb, libgnat/g-dynhta.ads: New package
Dynamic_HTable.
gcc/testsuite/
* gnat.dg/dynhash.adb: New testcase.
From-SVN: r263709
-rw-r--r-- | gcc/ada/ChangeLog | 5 | ||||
-rw-r--r-- | gcc/ada/libgnat/g-dynhta.adb | 834 | ||||
-rw-r--r-- | gcc/ada/libgnat/g-dynhta.ads | 310 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 4 | ||||
-rw-r--r-- | gcc/testsuite/gnat.dg/dynhash.adb | 750 |
5 files changed, 1870 insertions, 33 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1161394..31420a3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +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. diff --git a/gcc/ada/libgnat/g-dynhta.adb b/gcc/ada/libgnat/g-dynhta.adb index a6e2734..b093e79 100644 --- a/gcc/ada/libgnat/g-dynhta.adb +++ b/gcc/ada/libgnat/g-dynhta.adb @@ -38,11 +38,10 @@ package body GNAT.Dynamic_HTables is ------------------- 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 -- @@ -363,7 +362,834 @@ package body GNAT.Dynamic_HTables is 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; diff --git a/gcc/ada/libgnat/g-dynhta.ads b/gcc/ada/libgnat/g-dynhta.ads index ea331c0..41574fd 100644 --- a/gcc/ada/libgnat/g-dynhta.ads +++ b/gcc/ada/libgnat/g-dynhta.ads @@ -31,13 +31,11 @@ -- 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 @@ -48,6 +46,8 @@ -- GNAT.HTable to keep as much coherency as possible between these two -- related units. +pragma Compiler_Unit_Warning; + package GNAT.Dynamic_HTables is ------------------- @@ -85,40 +85,38 @@ 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 @@ -126,11 +124,11 @@ package GNAT.Dynamic_HTables is -- 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; @@ -169,11 +167,10 @@ package GNAT.Dynamic_HTables is -- 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; @@ -233,7 +230,6 @@ package GNAT.Dynamic_HTables is -- same restrictions apply as Get_Next. private - type Element_Wrapper; type Elmt_Ptr is access all Element_Wrapper; type Element_Wrapper is record @@ -260,7 +256,263 @@ package GNAT.Dynamic_HTables is 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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 13faad8..2c02ca1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +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. diff --git a/gcc/testsuite/gnat.dg/dynhash.adb b/gcc/testsuite/gnat.dg/dynhash.adb new file mode 100644 index 0000000..79e1b98 --- /dev/null +++ b/gcc/testsuite/gnat.dg/dynhash.adb @@ -0,0 +1,750 @@ +-- { 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; |