-------------------------------------------------------------------------------
--
-- <STRONG>Copyright (c) 2001, 2002 by Thomas Wolf.</STRONG>
-- <BLOCKQUOTE>
--    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 <EM>without any warranty</EM>; without even the implied
--    warranty of <EM>merchantability or fitness for a particular purpose.</EM>
--    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 "<A HREF="GPL.txt">GPL.txt</A>". If not, write to the Free
--    Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
--    USA.
-- </BLOCKQUOTE>
-- <BLOCKQUOTE>
--   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.
-- </BLOCKQUOTE>
--
-- <DL><DT><STRONG>
-- Author:</STRONG><DD>
--   Thomas Wolf  (TW)
--   <ADDRESS><A HREF="mailto:twolf@acm.org">twolf@acm.org</A></ADDRESS></DL>
--
-- <DL><DT><STRONG>
-- Purpose:</STRONG><DD>
--   Provides dynamic hash tables. Internal collision resolution, automatic
--   and explicit resizing. Collision chain index computation can be customized
--   though <CODE>Collision_Policies</CODE>
--   </DL>.
--
-- <DL><DT><STRONG>
-- Tasking semantics:</STRONG><DD>
--   N/A. Not abortion-safe.</DL>
--
-- <DL><DT><STRONG>
-- Storage semantics:</STRONG><DD>
--   Dynamic storage allocation in a user-supplied storage pool.</DL>
--
-- <!--
-- Revision History
--
--   20-DEC-2001   TW  Initial version.
--   24-APR-2002   TW  Added the 'Choose_Size' generic formal function.
-- -->
-------------------------------------------------------------------------------

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;







