------------------------------------------------------------------------------ -- -- -- 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-2024, 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 -- -- . -- -- -- -- 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;