| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUN-TIME COMPONENTS -- |
| -- -- |
| -- G N A T . D Y N A M I C _ H T A B L E S -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2002-2022, AdaCore -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
| -- -- |
| -- As a special exception under Section 7 of GPL version 3, you are granted -- |
| -- additional permissions described in the GCC Runtime Library Exception, -- |
| -- version 3.1, as published by the Free Software Foundation. -- |
| -- -- |
| -- You should have received a copy of the GNU General Public License and -- |
| -- a copy of the GCC Runtime Library Exception along with this program; -- |
| -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- |
| -- <http://www.gnu.org/licenses/>. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Ada.Unchecked_Deallocation; |
| |
| package body GNAT.Dynamic_HTables is |
| |
| ------------------- |
| -- Hash_Two_Keys -- |
| ------------------- |
| |
| function Hash_Two_Keys |
| (Left : Bucket_Range_Type; |
| Right : Bucket_Range_Type) return Bucket_Range_Type |
| is |
| Half : constant := 2 ** (Bucket_Range_Type'Size / 2); |
| Mask : constant := Half - 1; |
| |
| begin |
| -- The hash is obtained in the following manner: |
| -- |
| -- 1) The low bits of Left are obtained, then shifted over to the high |
| -- bits position. |
| -- |
| -- 2) The low bits of Right are obtained |
| -- |
| -- The results from 1) and 2) are or-ed to produce a value within the |
| -- range of Bucket_Range_Type. |
| |
| return |
| ((Left and Mask) * Half) |
| or |
| (Right and Mask); |
| end Hash_Two_Keys; |
| |
| ------------------- |
| -- Static_HTable -- |
| ------------------- |
| |
| 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. |
| |
| --------- |
| -- Get -- |
| --------- |
| |
| function Get (T : Instance; K : Key) return Elmt_Ptr is |
| Elmt : Elmt_Ptr; |
| |
| begin |
| if T = null then |
| return Null_Ptr; |
| end if; |
| |
| Elmt := T.Table (Hash (K)); |
| |
| loop |
| if Elmt = Null_Ptr then |
| return Null_Ptr; |
| |
| elsif Equal (Get_Key (Elmt), K) then |
| return Elmt; |
| |
| else |
| Elmt := Next (Elmt); |
| end if; |
| end loop; |
| end Get; |
| |
| --------------- |
| -- Get_First -- |
| --------------- |
| |
| function Get_First (T : Instance) return Elmt_Ptr is |
| begin |
| if T = null then |
| return Null_Ptr; |
| end if; |
| |
| T.Iterator_Started := True; |
| T.Iterator_Index := T.Table'First; |
| T.Iterator_Ptr := T.Table (T.Iterator_Index); |
| return Get_Non_Null (T); |
| end Get_First; |
| |
| -------------- |
| -- Get_Next -- |
| -------------- |
| |
| function Get_Next (T : Instance) return Elmt_Ptr is |
| begin |
| if T = null or else not T.Iterator_Started then |
| return Null_Ptr; |
| end if; |
| |
| T.Iterator_Ptr := Next (T.Iterator_Ptr); |
| return Get_Non_Null (T); |
| end Get_Next; |
| |
| ------------------ |
| -- Get_Non_Null -- |
| ------------------ |
| |
| function Get_Non_Null (T : Instance) return Elmt_Ptr is |
| begin |
| if T = null then |
| return Null_Ptr; |
| end if; |
| |
| while T.Iterator_Ptr = Null_Ptr loop |
| if T.Iterator_Index = T.Table'Last then |
| T.Iterator_Started := False; |
| return Null_Ptr; |
| end if; |
| |
| T.Iterator_Index := T.Iterator_Index + 1; |
| T.Iterator_Ptr := T.Table (T.Iterator_Index); |
| end loop; |
| |
| return T.Iterator_Ptr; |
| end Get_Non_Null; |
| |
| ------------ |
| -- Remove -- |
| ------------ |
| |
| procedure Remove (T : Instance; K : Key) is |
| Index : constant Header_Num := Hash (K); |
| Elmt : Elmt_Ptr; |
| Next_Elmt : Elmt_Ptr; |
| |
| begin |
| if T = null then |
| return; |
| end if; |
| |
| Elmt := T.Table (Index); |
| |
| if Elmt = Null_Ptr then |
| return; |
| |
| elsif Equal (Get_Key (Elmt), K) then |
| T.Table (Index) := Next (Elmt); |
| |
| else |
| loop |
| Next_Elmt := Next (Elmt); |
| |
| if Next_Elmt = Null_Ptr then |
| return; |
| |
| elsif Equal (Get_Key (Next_Elmt), K) then |
| Set_Next (Elmt, Next (Next_Elmt)); |
| return; |
| |
| else |
| Elmt := Next_Elmt; |
| end if; |
| end loop; |
| end if; |
| end Remove; |
| |
| ----------- |
| -- Reset -- |
| ----------- |
| |
| procedure Reset (T : in out Instance) is |
| procedure Free is |
| new Ada.Unchecked_Deallocation (Instance_Data, Instance); |
| |
| begin |
| if T = null then |
| return; |
| end if; |
| |
| for J in T.Table'Range loop |
| T.Table (J) := Null_Ptr; |
| end loop; |
| |
| Free (T); |
| end Reset; |
| |
| --------- |
| -- Set -- |
| --------- |
| |
| procedure Set (T : in out Instance; E : Elmt_Ptr) is |
| Index : Header_Num; |
| |
| begin |
| if T = null then |
| T := new Instance_Data; |
| end if; |
| |
| Index := Hash (Get_Key (E)); |
| Set_Next (E, T.Table (Index)); |
| T.Table (Index) := E; |
| end Set; |
| |
| end Static_HTable; |
| |
| ------------------- |
| -- Simple_HTable -- |
| ------------------- |
| |
| package body Simple_HTable is |
| procedure Free is new |
| Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr); |
| |
| --------- |
| -- Get -- |
| --------- |
| |
| function Get (T : Instance; K : Key) return Element is |
| Tmp : Elmt_Ptr; |
| |
| begin |
| if T = Nil then |
| return No_Element; |
| end if; |
| |
| Tmp := Tab.Get (Tab.Instance (T), K); |
| |
| if Tmp = null then |
| return No_Element; |
| else |
| return Tmp.E; |
| end if; |
| end Get; |
| |
| --------------- |
| -- Get_First -- |
| --------------- |
| |
| function Get_First (T : Instance) return Element is |
| Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T)); |
| |
| begin |
| if Tmp = null then |
| return No_Element; |
| else |
| return Tmp.E; |
| end if; |
| end Get_First; |
| |
| ------------------- |
| -- Get_First_Key -- |
| ------------------- |
| |
| function Get_First_Key (T : Instance) return Key_Option is |
| Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T)); |
| begin |
| if Tmp = null then |
| return Key_Option'(Present => False); |
| else |
| return Key_Option'(Present => True, K => Tmp.all.K); |
| end if; |
| end Get_First_Key; |
| |
| ------------- |
| -- Get_Key -- |
| ------------- |
| |
| function Get_Key (E : Elmt_Ptr) return Key is |
| begin |
| return E.K; |
| end Get_Key; |
| |
| -------------- |
| -- Get_Next -- |
| -------------- |
| |
| function Get_Next (T : Instance) return Element is |
| Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T)); |
| begin |
| if Tmp = null then |
| return No_Element; |
| else |
| return Tmp.E; |
| end if; |
| end Get_Next; |
| |
| ------------------ |
| -- Get_Next_Key -- |
| ------------------ |
| |
| function Get_Next_Key (T : Instance) return Key_Option is |
| Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T)); |
| begin |
| if Tmp = null then |
| return Key_Option'(Present => False); |
| else |
| return Key_Option'(Present => True, K => Tmp.all.K); |
| end if; |
| end Get_Next_Key; |
| |
| ---------- |
| -- Next -- |
| ---------- |
| |
| function Next (E : Elmt_Ptr) return Elmt_Ptr is |
| begin |
| return E.Next; |
| end Next; |
| |
| ------------ |
| -- Remove -- |
| ------------ |
| |
| procedure Remove (T : Instance; K : Key) is |
| Tmp : Elmt_Ptr; |
| |
| begin |
| Tmp := Tab.Get (Tab.Instance (T), K); |
| |
| if Tmp /= null then |
| Tab.Remove (Tab.Instance (T), K); |
| Free (Tmp); |
| end if; |
| end Remove; |
| |
| ----------- |
| -- Reset -- |
| ----------- |
| |
| procedure Reset (T : in out Instance) is |
| E1, E2 : Elmt_Ptr; |
| |
| begin |
| E1 := Tab.Get_First (Tab.Instance (T)); |
| while E1 /= null loop |
| E2 := Tab.Get_Next (Tab.Instance (T)); |
| Free (E1); |
| E1 := E2; |
| end loop; |
| |
| Tab.Reset (Tab.Instance (T)); |
| end Reset; |
| |
| --------- |
| -- Set -- |
| --------- |
| |
| procedure Set (T : in out Instance; K : Key; E : Element) is |
| Tmp : constant Elmt_Ptr := Tab.Get (Tab.Instance (T), K); |
| begin |
| if Tmp = null then |
| Tab.Set (Tab.Instance (T), new Element_Wrapper'(K, E, null)); |
| else |
| Tmp.E := E; |
| end if; |
| end Set; |
| |
| -------------- |
| -- Set_Next -- |
| -------------- |
| |
| procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is |
| begin |
| E.Next := Next; |
| end Set_Next; |
| end Simple_HTable; |
| |
| ------------------------- |
| -- Dynamic_Hash_Tables -- |
| ------------------------- |
| |
| package body Dynamic_Hash_Tables is |
| Minimum_Size : constant Bucket_Range_Type := 8; |
| -- 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 Delete_Node |
| (T : Dynamic_Hash_Table; |
| Nod : Node_Ptr); |
| pragma Inline (Delete_Node); |
| -- Detach and delete node Nod from table T |
| |
| 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 : Dynamic_Hash_Table); |
| pragma Inline (Ensure_Created); |
| -- Verify that hash table T is created. Raise Not_Created if this is not |
| -- the case. |
| |
| procedure Ensure_Unlocked (T : Dynamic_Hash_Table); |
| pragma Inline (Ensure_Unlocked); |
| -- Verify that hash table T is unlocked. Raise Iterated 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 : Dynamic_Hash_Table; |
| 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 |
| (Dynamic_Hash_Table_Attributes, Dynamic_Hash_Table); |
| |
| 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 : Dynamic_Hash_Table) return Threshold_Type; |
| pragma Inline (Load_Factor); |
| -- Calculate the load factor of hash table T |
| |
| procedure Lock (T : Dynamic_Hash_Table); |
| pragma Inline (Lock); |
| -- Lock all mutation functionality of hash table T |
| |
| procedure Mutate_And_Rehash |
| (T : Dynamic_Hash_Table; |
| 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 |
| |
| function Present (Bkts : Bucket_Table_Ptr) return Boolean; |
| pragma Inline (Present); |
| -- Determine whether buckets Bkts exist |
| |
| function Present (Nod : Node_Ptr) return Boolean; |
| pragma Inline (Present); |
| -- Determine whether node Nod exists |
| |
| procedure Unlock (T : Dynamic_Hash_Table); |
| pragma Inline (Unlock); |
| -- Unlock all mutation functionality of hash table T |
| |
| -------------- |
| -- Contains -- |
| -------------- |
| |
| function Contains |
| (T : Dynamic_Hash_Table; |
| Key : Key_Type) return Boolean |
| 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); |
| |
| return Is_Valid (Nod, Head); |
| end Contains; |
| |
| ------------ |
| -- Create -- |
| ------------ |
| |
| function Create (Initial_Size : Positive) return Dynamic_Hash_Table is |
| Size : constant Bucket_Range_Type := |
| Bucket_Range_Type'Max |
| (Bucket_Range_Type (Initial_Size), Minimum_Size); |
| -- Ensure that the buckets meet a minimum size |
| |
| T : constant Dynamic_Hash_Table := new Dynamic_Hash_Table_Attributes; |
| |
| begin |
| T.Buckets := new Bucket_Table (0 .. Size - 1); |
| T.Initial_Size := Size; |
| |
| return T; |
| end Create; |
| |
| ------------ |
| -- Delete -- |
| ------------ |
| |
| procedure Delete |
| (T : Dynamic_Hash_Table; |
| Key : Key_Type) |
| is |
| Head : Node_Ptr; |
| Nod : Node_Ptr; |
| |
| 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 |
| Delete_Node (T, Nod); |
| end if; |
| end Delete; |
| |
| ----------------- |
| -- Delete_Node -- |
| ----------------- |
| |
| procedure Delete_Node |
| (T : Dynamic_Hash_Table; |
| Nod : Node_Ptr) |
| 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 (Present (T)); |
| pragma Assert (Present (T.Buckets)); |
| |
| 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 |
| |
| Ref : Node_Ptr := Nod; |
| |
| -- Start of processing for Delete_Node |
| |
| begin |
| pragma Assert (Present (Ref)); |
| pragma Assert (Present (T)); |
| |
| Detach (Ref); |
| Free (Ref); |
| |
| -- The number of key-value pairs is updated when the hash table |
| -- contains a valid node which represents the pair. |
| |
| T.Pairs := T.Pairs - 1; |
| |
| -- Compress the hash table if the load factor drops below the value |
| -- of Compression_Threshold. |
| |
| Compress; |
| end Delete_Node; |
| |
| ------------- |
| -- Destroy -- |
| ------------- |
| |
| procedure Destroy (T : in out Dynamic_Hash_Table) 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; |
| |
| -- Invoke the value destructor before deallocating the node |
| |
| Destroy_Value (Nod.Value); |
| |
| Detach (Nod); |
| Free (Nod); |
| end loop; |
| end Destroy_Bucket; |
| |
| -- Start of processing for Destroy_Buckets |
| |
| begin |
| pragma Assert (Present (Bkts)); |
| |
| 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 (Present (Nod)); |
| |
| Next : constant Node_Ptr := Nod.Next; |
| Prev : constant Node_Ptr := Nod.Prev; |
| |
| begin |
| pragma Assert (Present (Next)); |
| pragma Assert (Present (Prev)); |
| |
| Prev.Next := Next; -- Prev ---> Next |
| Next.Prev := Prev; -- Prev <--> Next |
| |
| Nod.Next := null; |
| Nod.Prev := null; |
| end Detach; |
| |
| --------------------- |
| -- Ensure_Circular -- |
| --------------------- |
| |
| procedure Ensure_Circular (Head : Node_Ptr) is |
| pragma Assert (Present (Head)); |
| |
| begin |
| if not Present (Head.Next) and then not Present (Head.Prev) then |
| Head.Next := Head; |
| Head.Prev := Head; |
| end if; |
| end Ensure_Circular; |
| |
| -------------------- |
| -- Ensure_Created -- |
| -------------------- |
| |
| procedure Ensure_Created (T : Dynamic_Hash_Table) is |
| begin |
| if not Present (T) then |
| raise Not_Created; |
| end if; |
| end Ensure_Created; |
| |
| --------------------- |
| -- Ensure_Unlocked -- |
| --------------------- |
| |
| procedure Ensure_Unlocked (T : Dynamic_Hash_Table) is |
| begin |
| pragma Assert (Present (T)); |
| |
| -- The hash table has at least one outstanding iterator |
| |
| if T.Iterators > 0 then |
| raise Iterated; |
| end if; |
| end Ensure_Unlocked; |
| |
| ----------------- |
| -- Find_Bucket -- |
| ----------------- |
| |
| function Find_Bucket |
| (Bkts : Bucket_Table_Ptr; |
| Key : Key_Type) return Node_Ptr |
| is |
| pragma Assert (Present (Bkts)); |
| |
| 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 (Present (Head)); |
| |
| 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 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 : Dynamic_Hash_Table; |
| 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 (Present (T)); |
| pragma Assert (Present (T.Buckets)); |
| |
| -- 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 : Dynamic_Hash_Table; |
| 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 Dynamic_Hash_Table := Iter.Table; |
| |
| begin |
| pragma Assert (Present (T)); |
| |
| -- 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_Empty -- |
| -------------- |
| |
| function Is_Empty (T : Dynamic_Hash_Table) return Boolean is |
| begin |
| Ensure_Created (T); |
| |
| return T.Pairs = 0; |
| end Is_Empty; |
| |
| -------------- |
| -- 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 Present (Iter.Curr_Nod); |
| 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 Present (Nod) and then Nod /= Head; |
| end Is_Valid; |
| |
| ------------- |
| -- Iterate -- |
| ------------- |
| |
| function Iterate (T : Dynamic_Hash_Table) return Iterator is |
| Iter : Iterator; |
| |
| begin |
| Ensure_Created (T); |
| pragma Assert (Present (T.Buckets)); |
| |
| -- 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.Curr_Idx, |
| Nod => Iter.Curr_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 : Dynamic_Hash_Table) return Threshold_Type is |
| pragma Assert (Present (T)); |
| pragma Assert (Present (T.Buckets)); |
| |
| 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 : Dynamic_Hash_Table) is |
| begin |
| -- The hash table may be locked multiple times if multiple iterators |
| -- are operating over it. |
| |
| T.Iterators := T.Iterators + 1; |
| end Lock; |
| |
| ----------------------- |
| -- Mutate_And_Rehash -- |
| ----------------------- |
| |
| procedure Mutate_And_Rehash |
| (T : Dynamic_Hash_Table; |
| 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 (Present (From)); |
| pragma Assert (Present (To)); |
| |
| 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 (Present (Head)); |
| |
| 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 (Present (Nod)); |
| |
| 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 (Present (T)); |
| |
| 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.Curr_Nod; |
| T : constant Dynamic_Hash_Table := Iter.Table; |
| Head : Node_Ptr; |
| |
| begin |
| pragma Assert (Present (T)); |
| pragma Assert (Present (T.Buckets)); |
| |
| -- 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.Curr_Nod := Iter.Curr_Nod.Next; |
| Head := T.Buckets (Iter.Curr_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.Curr_Nod, Head) then |
| First_Valid_Node |
| (T => T, |
| Low_Bkt => Iter.Curr_Idx + 1, |
| High_Bkt => T.Buckets'Last, |
| Idx => Iter.Curr_Idx, |
| Nod => Iter.Curr_Nod); |
| end if; |
| |
| Key := Saved.Key; |
| end Next; |
| |
| ------------- |
| -- Prepend -- |
| ------------- |
| |
| procedure Prepend (Nod : Node_Ptr; Head : Node_Ptr) is |
| pragma Assert (Present (Nod)); |
| pragma Assert (Present (Head)); |
| |
| Next : constant Node_Ptr := Head.Next; |
| |
| begin |
| Head.Next := Nod; |
| Next.Prev := Nod; |
| |
| Nod.Next := Next; |
| Nod.Prev := Head; |
| end Prepend; |
| |
| ------------- |
| -- Present -- |
| ------------- |
| |
| function Present (Bkts : Bucket_Table_Ptr) return Boolean is |
| begin |
| return Bkts /= null; |
| end Present; |
| |
| ------------- |
| -- Present -- |
| ------------- |
| |
| function Present (Nod : Node_Ptr) return Boolean is |
| begin |
| return Nod /= null; |
| end Present; |
| |
| ------------- |
| -- Present -- |
| ------------- |
| |
| function Present (T : Dynamic_Hash_Table) return Boolean is |
| begin |
| return T /= Nil; |
| end Present; |
| |
| --------- |
| -- Put -- |
| --------- |
| |
| procedure Put |
| (T : Dynamic_Hash_Table; |
| 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 (Present (T)); |
| pragma Assert (Present (T.Buckets)); |
| |
| 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 (Present (Head)); |
| |
| 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 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); |
| |
| -- The number of key-value pairs must be updated for a prepend, |
| -- never for a replace. |
| |
| T.Pairs := T.Pairs + 1; |
| 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); |
| |
| -- Expand the hash table if the ratio of pairs to buckets goes over |
| -- Expansion_Threshold. |
| |
| Expand; |
| end Put; |
| |
| ----------- |
| -- Reset -- |
| ----------- |
| |
| procedure Reset (T : Dynamic_Hash_Table) 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 : Dynamic_Hash_Table) return Natural is |
| begin |
| Ensure_Created (T); |
| |
| return T.Pairs; |
| end Size; |
| |
| ------------ |
| -- Unlock -- |
| ------------ |
| |
| procedure Unlock (T : Dynamic_Hash_Table) is |
| begin |
| -- The hash table may be locked multiple times if multiple iterators |
| -- are operating over it. |
| |
| T.Iterators := T.Iterators - 1; |
| end Unlock; |
| end Dynamic_Hash_Tables; |
| |
| end GNAT.Dynamic_HTables; |
