------------------------------------------------------------------------------- -- -- Copyright (c) 2001, 2002 by Thomas Wolf. --
-- This piece of software is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as published -- by the Free Software Foundation; either version 2, or (at your option) -- any later version. This unit is distributed in the hope that it will be -- useful, but without any warranty; without even the implied -- warranty of merchantability or fitness for a particular purpose. -- See the GNU General Public License for more details. You should have -- received a copy of the GNU General Public License with this distribution, -- see file "GPL.txt". If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, -- USA. --
--
-- As a special exception from the GPL, if other files instantiate generics -- from this unit, or you link this unit with other files to produce an -- executable, this unit does not by itself cause the resulting executable -- to be covered by the GPL. This exception does not however invalidate any -- other reasons why the executable file might be covered by the GPL. --
-- --
-- Author:
-- Thomas Wolf (TW) --
twolf@acm.org
-- --
-- Purpose:
-- Provides dynamic hash tables. Internal collision resolution, automatic -- and explicit resizing. Collision chain index computation can be customized -- though Collision_Policies --
. -- --
-- Tasking semantics:
-- N/A. Not abortion-safe.
-- --
-- Storage semantics:
-- Dynamic storage allocation in a user-supplied storage pool.
-- -- ------------------------------------------------------------------------------- pragma License (Modified_GPL); with Ada.Unchecked_Deallocation; with GAL.Support.Hashing; -- generic -- type Key_Type (<>) is private; -- type Item (<>) is private; -- -- with package Memory is new GAL.Storage.Memory (<>); -- -- Initial_Size : in GAL.Support.Hashing.Size_Type := 23; -- -- with function Hash -- (Element : in Key_Type) -- return GAL.Support.Hashing.Hash_Type is <>; -- -- with function "=" (Left, Right : in Key_Type) return Boolean is <>; -- -- with function Choose_Size -- (Suggested : in GAL.Support.Hashing.Hash_Type) -- return GAL.Support.Hashing.Hash_Type -- is GAL.Support.Hashing.Next_Prime; -- -- This function is called whenever the size of the hash table is to be -- -- defined. 'Suggested' is the suggested size of the new table; the -- -- function should then return a size that is >= Suggested. If it -- -- returns a smaller value anyway, the exception 'Container_Error' is -- -- raised. package body GAL.ADT.Hash_Tables is use GAL.Support.Hashing; procedure Free is new Ada.Unchecked_Deallocation (Mem, Ptr); procedure Free is new Ada.Unchecked_Deallocation (Key_Type, Key_Ptr); procedure Free is new Ada.Unchecked_Deallocation (Item, Data_Ptr); procedure Free is new Ada.Unchecked_Deallocation (Collision_Policy'Class, Collision_Policy_Ptr); procedure Free is new Ada.Unchecked_Deallocation (Growth_Policy'Class, Growth_Policy_Ptr); ---------------------------------------------------------------------------- function Round_Up (Suggested : in Hash_Type) return Hash_Type is Min_Size : constant Hash_Type := Hash_Type'Max (Suggested, 3); Result : constant Hash_Type := Choose_Size (Min_Size); begin if Result < Min_Size then raise Container_Error; end if; return Result; end Round_Up; ---------------------------------------------------------------------------- function Copy (Old : access Mem) return Ptr is Result : constant Ptr := new Mem (Old'Range); begin for I in Old'Range loop Result (I).State := Old (I).State; if Old (I).State = Used then Result (I).Value := new Item'(Old (I).Value.all); Result (I).Key := new Key_Type'(Old (I).Key.all); end if; end loop; return Result; end Copy; ---------------------------------------------------------------------------- procedure Grow (Table : in out Hash_Table; Grown : out Boolean); -- Forward declaration; we have a mutual recursion here between 'Grow' and -- 'Add'. procedure Add (Table : in out Hash_Table; Key : in Key_Ptr; Element : in Data_Ptr) is H : constant Hash_Type := Hash (Key.all); Start : Hash_Type := H mod Table.Table'Length + 1; N : Natural := 0; Curr : Hash_Type := Start; Index : Hash_Type := 0; Grown : Boolean := False; begin loop case Table.Table (Curr).State is when Empty => -- Not found! if Index = 0 then Index := Curr; end if; exit; when Deleted => -- A hole in the chain? if Index = 0 then Index := Curr; exit when Grown; end if; -- Continue!! when Used => null; end case; N := N + 1; Curr := Next (Table.Collisions, Curr, H, Table.Table'Length, N); if Curr = 0 or else Curr = Start then exit when Index > 0; -- No useable slot found on the whole chain, and we may grow the -- table: grow it! Grow (Table, Grown); exit when not Grown; -- Then re-try, just to find a useable slot: Start := H mod Table.Table'Length + 1; Curr := Start; N := 0; Index := 0; end if; end loop; if Index = 0 then raise Container_Full; end if; Table.Table (Index).State := Used; Table.Table (Index).Key := Key; Table.Table (Index).Value := Element; Table.Count := Table.Count + 1; end Add; procedure Rehash (Table : in out Hash_Table; Size : in Size_Type) is New_Table : constant Ptr := new Mem (1 .. Size); Old_Table : Ptr := Table.Table; N : Hash_Type := Table.Count; begin Table.Table := New_Table; Table.Count := 0; if Old_Table /= null then if N > 0 then for I in Old_Table'Range loop if Old_Table (I).State = Used then Add (Table, Old_Table (I).Key, Old_Table (I).Value); N := N - 1; exit when N = 0; end if; end loop; end if; Free (Old_Table); end if; end Rehash; procedure Grow (Table : in out Hash_Table; Grown : out Boolean) is Curr_Size : Hash_Type; New_Size : Size_Type; begin Grown := False; if Table.Growth = null then return; end if; if Table.Table = null then Curr_Size := 0; else Curr_Size := Table.Table'Length; end if; New_Size := Round_Up (Increase (Table.Growth, Curr_Size)); if New_Size <= Curr_Size then return; end if; Rehash (Table, New_Size); Grown := True; end Grow; procedure Find (Table : in out Hash_Table; Key : in Key_Type; Index : out Hash_Type; Found : out Boolean; May_Grow : in Boolean) is H : constant Hash_Type := Hash (Key); Start : Hash_Type := H mod Table.Table'Length + 1; N : Natural := 0; Curr : Hash_Type := Start; Grown : Boolean := False; begin Index := 0; Found := False; loop case Table.Table (Curr).State is when Empty => -- Not found! if Index = 0 then Index := Curr; end if; exit; when Deleted => -- A hole in the chain? if Index = 0 then Index := Curr; exit when Grown; end if; -- Continue!! when Used => if not Grown and then Table.Table (Curr).Key.all = Key then Index := Curr; Found := True; exit; end if; -- If we've already grown the table, we need not check the -- keys again; we already know that the key is not in the -- table. We just want to find an index where we might -- store the item. end case; N := N + 1; Curr := Next (Table.Collisions, Curr, H, Table.Table'Length, N); if Curr = 0 or else Curr = Start then exit when Index > 0 or else not May_Grow; -- No useable slot found on the whole chain, and we may grow the -- table: grow it! Grow (Table, Grown); exit when not Grown; -- Then re-try, just to find a useable slot: Start := H mod Table.Table'Length + 1; Curr := Start; N := 0; Index := 0; end if; end loop; end Find; procedure Find (Table : in Hash_Table; Key : in Key_Type; Index : out Hash_Type; Found : out Boolean) is H : constant Hash_Type := Hash (Key); Start : constant Hash_Type := H mod Table.Table'Length + 1; N : Natural := 0; Curr : Hash_Type := Start; begin Index := 0; Found := False; loop case Table.Table (Curr).State is when Empty => -- Not found! if Index = 0 then Index := Curr; end if; exit; when Deleted => -- A hole in the chain? if Index = 0 then Index := Curr; end if; -- Continue!! when Used => if Table.Table (Curr).Key.all = Key then Index := Curr; Found := True; exit; end if; end case; N := N + 1; exit when Table.Collisions = null; -- Hey, if the collision policy is still null, we never ever had -- a collision, and hence we needn't continue! Curr := Next (Table.Collisions, Curr, H, Table.Table'Length, N); exit when Curr = 0 or else Curr = Start; end loop; end Find; procedure Add (Table : in out Hash_Table; Key : in Key_Type; Element : in Item; Overwrite : in Boolean := False) is Index : Hash_Type; Found : Boolean; begin if Table.Table = null then Table.Table := new Mem (1 .. Round_Up (Table.Initial_Size)); end if; if Table.Collisions = null then Table.Collisions := new Default_Collision_Policy; end if; declare Length : constant Hash_Type := Table.Table'Length; begin Find (Table, Key, Index, Found, True); if Found then if Overwrite then Free (Table.Table (Index).Key); Table.Table (Index).Key := new Key_Type'(Key); Free (Table.Table (Index).Value); Table.Table (Index).Value := new Item'(Element); return; else raise Duplicate_Key; end if; end if; if Index = 0 then raise Container_Full; end if; if Length = Table.Table'Length -- We didn't re-size and then Table.Resize_At /= 0.0 -- and we may resize and then Load_Factor (Float (Table.Count + 1) / Float (Length)) > Table.Resize_At -- and the table is pretty full then Resize : declare Grown : Boolean; begin Grow (Table, Grown); if Grown then Find (Table, Key, Index, Found, True); if Index = 0 then -- Shouldn't happen! raise Container_Error; end if; end if; end Resize; end if; end; -- Insert it at 'Index': Table.Table (Index).State := Used; Table.Table (Index).Key := new Key_Type'(Key); Table.Table (Index).Value := new Item'(Element); Table.Count := Table.Count + 1; end Add; procedure Add (Table : in out Hash_Table; Key : in Key_Type; Element : access Item; Overwrite : in Boolean := False) is Index : Hash_Type; Found : Boolean; begin if Table.Table = null then Table.Table := new Mem (1 .. Round_Up (Table.Initial_Size)); end if; if Table.Collisions = null then Table.Collisions := new Default_Collision_Policy; end if; declare Length : constant Hash_Type := Table.Table'Length; begin Find (Table, Key, Index, Found, True); if Found then if Overwrite then Free (Table.Table (Index).Key); Table.Table (Index).Key := new Key_Type'(Key); Free (Table.Table (Index).Value); Table.Table (Index).Value := new Item'(Element.all); return; else raise Duplicate_Key; end if; end if; if Index = 0 then raise Container_Full; end if; if Length = Table.Table'Length -- We didn't re-size and then Table.Resize_At /= 0.0 -- and we may resize and then Load_Factor (Float (Table.Count + 1) / Float (Length)) > Table.Resize_At -- and the table is pretty full then Resize : declare Grown : Boolean; begin Grow (Table, Grown); if Grown then Find (Table, Key, Index, Found, True); if Index = 0 then -- Shouldn't happen! raise Container_Error; end if; end if; end Resize; end if; end; -- Insert it at 'Index': Table.Table (Index).State := Used; Table.Table (Index).Key := new Key_Type'(Key); Table.Table (Index).Value := new Item'(Element.all); Table.Count := Table.Count + 1; end Add; procedure Insert (Table : in out Hash_Table; Key : in Key_Type; Element : in Item) is begin Add (Table, Key, Element, False); end Insert; procedure Insert (Table : in out Hash_Table; Key : in Key_Type; Element : access Item) is begin Add (Table, Key, Element, False); end Insert; ---------------------------------------------------------------------------- procedure Replace (Table : in out Hash_Table; Key : in Key_Type; Element : in Item) is begin Add (Table, Key, Element, True); end Replace; procedure Replace (Table : in out Hash_Table; Key : in Key_Type; Element : access Item) is begin Add (Table, Key, Element, True); end Replace; ---------------------------------------------------------------------------- procedure Delete (Table : in out Hash_Table; Key : in Key_Type) is Index : Hash_Type; Found : Boolean; begin if Table.Count = 0 then raise Container_Empty; end if; Find (Table, Key, Index, Found); if Found then Free (Table.Table (Index).Key); Free (Table.Table (Index).Value); Table.Table (Index).State := Deleted; Table.Count := Table.Count - 1; else raise Not_Found; end if; end Delete; procedure Delete (Table : in out Hash_Table; Key : in Key_Type; Element : out Item) is Index : Hash_Type; Found : Boolean; begin if Table.Count = 0 then raise Container_Empty; end if; Find (Table, Key, Index, Found); if Found then Element := Table.Table (Index).Value.all; -- Do this first, so that the table remains intact if it should raise -- an exception. Free (Table.Table (Index).Key); Free (Table.Table (Index).Value); Table.Table (Index).State := Deleted; Table.Count := Table.Count - 1; else raise Not_Found; end if; end Delete; ---------------------------------------------------------------------------- function Retrieve (Table : in Hash_Table; Key : in Key_Type) return Item is Index : Hash_Type; Found : Boolean; begin if Table.Count = 0 then raise Container_Empty; end if; Find (Table, Key, Index, Found); if not Found then raise Not_Found; end if; return Table.Table (Index).Value.all; end Retrieve; function Contains (Table : in Hash_Table; Key : in Key_Type) return Boolean is Index : Hash_Type; Found : Boolean; begin if Table.Count = 0 then return False; end if; Find (Table, Key, Index, Found); return Found; end Contains; ---------------------------------------------------------------------------- function Nof_Elements (Table : in Hash_Table) return Hash_Type is begin return Table.Count; end Nof_Elements; function Is_Empty (Table : in Hash_Table) return Boolean is begin return Table.Count = 0; end Is_Empty; function Load (Table : in Hash_Table) return Load_Factor is begin if Table.Table = null then return 0.0; end if; return Load_Factor (Float (Table.Count) / Float (Table.Table'Length)); end Load; function Size (Table : in Hash_Table) return Hash_Type is begin if Table.Table = null then return 0; end if; return Table.Table'Length; end Size; ---------------------------------------------------------------------------- procedure Swap (Left, Right : in out Hash_Table) is procedure Exchange is new GAL.Support.Swap (GAL.Support.Hashing.Hash_Type); procedure Exchange is new GAL.Support.Swap (Ptr); procedure Exchange is new GAL.Support.Swap (Collision_Policy_Ptr); procedure Exchange is new GAL.Support.Swap (Growth_Policy_Ptr); procedure Exchange is new GAL.Support.Swap (GAL.Support.Hashing.Load_Factor); begin Exchange (Left.Count, Right.Count); Exchange (Left.Table, Right.Table); Exchange (Left.Collisions, Right.Collisions); Exchange (Left.Growth, Right.Growth); Exchange (Left.Resize_At, Right.Resize_At); Exchange (Left.Initial_Size, Right.Initial_Size); end Swap; ---------------------------------------------------------------------------- procedure Resize (Table : in out Hash_Table; New_Size : in Size_Type) is -- The difference from 'Grow' above is that the table may shrink. Real_Size : constant Size_Type := Round_Up (New_Size); Curr_Size : Hash_Type; begin if Table.Table = null then Curr_Size := 0; else Curr_Size := Table.Table'Length; end if; if Real_Size < Table.Count then raise Container_Error; end if; if Real_Size = Curr_Size then return; end if; Rehash (Table, Real_Size); end Resize; ---------------------------------------------------------------------------- procedure Reset (Table : in out Hash_Table) is begin if Table.Table /= null and then Table.Count > 0 then declare N : Hash_Type := Table.Count; begin for I in Table.Table'Range loop if Table.Table (I).State = Used then Free (Table.Table (I).Key); Free (Table.Table (I).Value); N := N - 1; exit when N = 0; end if; end loop; end; end if; Table.Count := 0; if Table.Table /= null then Free (Table.Table); end if; Table.Table := null; end Reset; procedure Reset (Table : in out Hash_Table; New_Size : in Size_Type) is begin Reset (Table); Table.Initial_Size := New_Size; end Reset; procedure Reset (Table : in out Hash_Table; New_Size : in Size_Type; Resize_At : in Load_Factor) is begin Reset (Table, New_Size); Table.Resize_At := Resize_At; end Reset; ---------------------------------------------------------------------------- procedure Merge (Result : in out Hash_Table; Source : in Hash_Table) is begin if Source.Count = 0 then return; end if; if Result.Count = 0 then Reset (Result); Result.Count := Source.Count; Result.Table := Copy (Source.Table); return; else -- Both result and source have elements declare Copy : Hash_Table := Result; N : Hash_Type := Source.Count; begin for I in Source.Table'Range loop if Source.Table (I).State = Used then begin Insert (Copy, Source.Table (I).Key.all, Source.Table (I).Value); -- Raises Duplicate_Error if the key already exists. exception when Container_Full => Resize (Copy, 2 * Copy.Table'Length); Insert (Copy, Source.Table (I).Key.all, Source.Table (I).Value); end; N := N - 1; exit when N = 0; end if; end loop; Result := Copy; end; end if; end Merge; procedure Merge (Result : in out Hash_Table; Source : in Hash_Table; Overwrite : in Boolean) is begin if Source.Count = 0 then return; end if; if Result.Count = 0 then Merge (Result, Source); else declare N : Hash_Type := Source.Count; Index : Hash_Type; Found : Boolean; begin for I in Source.Table'Range loop if Source.Table (I).State = Used then Find (Result, Source.Table (I).Key.all, Index, Found, True); if Found then if Overwrite then Free (Result.Table (Index).Value); Result.Table (Index).Value := new Item'(Source.Table (I).Value.all); end if; else if Index = 0 then Resize (Result, 2 * Result.Table'Length); Find (Result, Source.Table (I).Key.all, Index, Found, True); if Index = 0 then raise Container_Error; end if; end if; Result.Table (Index).State := Used; Result.Table (Index).Key := new Key_Type'(Source.Table (I).Key.all); Result.Table (Index).Value := new Item'(Source.Table (I).Value.all); Result.Count := Result.Count + 1; end if; N := N - 1; exit when N = 0; end if; end loop; end; end if; end Merge; ---------------------------------------------------------------------------- -- Collision chain management. Every hash table has a collision policy; -- the default is to do exponential hashing, which seems to be least -- Susceptible to clustering (primary or secondary) and better than -- double hashing. -- -- (Note however that better is relative anyway. Depending on the -- circumstances, linear probing may in fact be the most appropriate -- choice, as it exhibits a good access locality and thus may be a win on -- modern processor architctures with multi-level caching.) procedure Set_Collision_Policy (Table : in out Hash_Table; Policy : in Collision_Policy'Class) is begin if Table.Collisions /= null then Free (Table.Collisions); end if; Table.Collisions := new Collision_Policy'Class'(Policy); if Table.Table /= null and then Table.Count > 0 then Rehash (Table, Table.Table'Length); end if; end Set_Collision_Policy; procedure Remove_Collision_Policy (Table : in out Hash_Table) is begin if Table.Collisions /= null and then Table.Collisions.all not in Default_Collision_Policy'Class then Free (Table.Collisions); Table.Collisions := new Default_Collision_Policy; if Table.Table /= null and then Table.Count > 0 then Rehash (Table, Table.Table'Length); end if; end if; end Remove_Collision_Policy; function Get_Collision_Policy (Table : in Hash_Table) return GAL.Support.Hashing.Collision_Policy'Class is begin return Table.Collisions.all; end Get_Collision_Policy; ---------------------------------------------------------------------------- procedure Set_Resize (Table : in out Hash_Table; Resize_At : in Load_Factor) is begin Table.Resize_At := Resize_At; end Set_Resize; procedure Set_Growth_Policy (Table : in out Hash_Table; Policy : in Growth_Policy'Class) is begin if Table.Growth /= null then Free (Table.Growth); end if; Table.Growth := new Growth_Policy'Class'(Policy); end Set_Growth_Policy; procedure Remove_Growth_Policy (Table : in out Hash_Table) is begin if Table.Growth /= null then Free (Table.Growth); end if; Table.Growth := null; end Remove_Growth_Policy; function Has_Growth_Policy (Table : in Hash_Table) return Boolean is begin return Table.Growth /= null; end Has_Growth_Policy; function Get_Growth_Policy (Table : in Hash_Table) return Growth_Policy'Class is begin return Table.Growth.all; end Get_Growth_Policy; ---------------------------------------------------------------------------- -- Traversals procedure Action (V : in out Visitor; Key : in Key_Type; Value : in out Item; Quit : in out Boolean) is pragma Warnings (Off, V); -- silence -gnatwa pragma Warnings (Off, Key); -- silence -gnatwa pragma Warnings (Off, Value); -- silence -gnatwa pragma Warnings (Off, Quit); -- silence -gnatwa begin null; end Action; procedure Action (V : in out Visitor; Key : in Key_Type; Value : access Item; Quit : in out Boolean) is pragma Warnings (Off, V); -- silence -gnatwa pragma Warnings (Off, Key); -- silence -gnatwa pragma Warnings (Off, Value); -- silence -gnatwa pragma Warnings (Off, Quit); -- silence -gnatwa begin null; end Action; -- generic -- with procedure Execute -- (Key : in Key_Type; -- Value : access Item; -- Quit : in out Boolean); procedure Traverse_By_Reference_G (Table : in Hash_Table) is begin if Table.Count = 0 then return; end if; declare Old_Table : constant Ptr := Table.Table; Old_Count : constant Hash_Type := Table.Count; N : Hash_Type := Old_Count; Quit : Boolean := False; begin for I in Table.Table'Range loop if Table.Table (I).State = Used then Execute (Table.Table (I).Key.all, Table.Table (I).Value, Quit); exit when Quit; if Table.Table /= Old_Table or else Table.Count /= Old_Count then -- ?? Table has been modified! raise Container_Error; end if; N := N - 1; exit when N = 0; end if; end loop; end; end Traverse_By_Reference_G; procedure Traverse (Table : in Hash_Table; V : in out Visitor'Class; Reference : in Boolean := False) is procedure Apply (Key : in Key_Type; Value : access Item; Quit : in out Boolean) is begin if Reference then Action (V, Key, Value, Quit); else Action (V, Key, Value.all, Quit); end if; end Apply; procedure Traverse is new Traverse_By_Reference_G (Apply); begin Traverse (Table); end Traverse; -- generic -- with procedure Execute -- (Key : in Key_Type; -- Value : in out Item; -- Quit : in out Boolean); procedure Traverse_G (Table : in Hash_Table) is procedure Apply (Key : in Key_Type; Value : access Item; Quit : in out Boolean) is begin Execute (Key, Value.all, Quit); end Apply; procedure Traverse is new Traverse_By_Reference_G (Apply); begin Traverse (Table); end Traverse_G; ---------------------------------------------------------------------------- package body Unsafe is function Retrieve (Table : in Hash_Table; Key : in Key_Type) return Item_Ptr is Index : Hash_Type; Found : Boolean; begin if Table.Count = 0 then return null; end if; Find (Table, Key, Index, Found); if not Found then return null; end if; return Item_Ptr (Table.Table (Index).Value); end Retrieve; end Unsafe; ---------------------------------------------------------------------------- -- Comparisons -- generic -- with function "=" (Left, Right : in Item) return Boolean is <>; function Equals (Left, Right : in Hash_Table) return Boolean is function Eq (L : access Mem; R : in Hash_Table; N : in Hash_Type) return Boolean is Not_Compared_Yet : Hash_Type := N; Index : Hash_Type; Found : Boolean; begin for I in L'Range loop if L (I).State = Used then Find (R, L (I).Key.all, Index, Found); if not Found or else L (I).Value.all /= R.Table (Index).Value.all then return False; end if; Not_Compared_Yet := Not_Compared_Yet - 1; exit when Not_Compared_Yet = 0; end if; end loop; return True; end Eq; begin -- Equals if Left.Count /= Right.Count then return False; end if; if Left.Table = Right.Table or else Left.Count = 0 then return True; end if; if Left.Table'Length > Right.Table'Length then return Eq (Right.Table, Left, Left.Count); else return Eq (Left.Table, Right, Left.Count); end if; end Equals; function "=" (Left, Right : in Hash_Table) return Boolean is function Dummy (L, R : in Item) return Boolean; pragma Inline (Dummy); function Dummy (L, R : in Item) return Boolean is pragma Warnings (Off, L); -- silence -gnatwa pragma Warnings (Off, R); -- silence -gnatwa begin return True; end Dummy; function Eq is new Equals (Dummy); begin -- "=" return Eq (Left, Right); end "="; ---------------------------------------------------------------------------- -- Controlled operations procedure Adjust (Table : in out Hash_Table) is begin if Table.Table /= null then Table.Table := Copy (Table.Table); end if; if Table.Collisions /= null then Table.Collisions := new Collision_Policy'Class'(Table.Collisions.all); end if; if Table.Growth /= null then Table.Growth := new Growth_Policy'Class'(Table.Growth.all); end if; end Adjust; procedure Finalize (Table : in out Hash_Table) is begin Reset (Table); if Table.Collisions /= null then Free (Table.Collisions); end if; Table.Collisions := null; if Table.Growth /= null then Free (Table.Growth); end if; Table.Growth := null; end Finalize; ---------------------------------------------------------------------------- -- Stream support. procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class; Table : in Hash_Table) is begin Hash_Type'Write (Stream, Table.Count); if Table.Count > 0 then declare N : Hash_Type := Table.Count; begin for I in Table.Table'Range loop if Table.Table (I).State = Used then Key_Type'Output (Stream, Table.Table (I).Key.all); Item'Output (Stream, Table.Table (I).Value.all); N := N - 1; exit when N = 0; end if; end loop; end; end if; end Write; procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class; Table : out Hash_Table) is N : Hash_Type; begin Hash_Type'Read (Stream, N); Reset (Table, N + 1); for I in 1 .. N loop declare Key : constant Key_Type := Key_Type'Input (Stream); Element : aliased Item := Item'Input (Stream); begin Insert (Table, Key, Element'Access); exception when Container_Full => -- Actually, that shouldn't happen if 'Choose_Size' and the -- collision resolution policy are well behaved. Resize (Table, 2 * Table.Table'Length); Insert (Table, Key, Element'Access); end; end loop; end Read; end GAL.ADT.Hash_Tables;