URL https://opencores.org/ocsvn/scarts/scarts/trunk

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [ada/] [a-chtgop.adb] - Blame information for rev 20

Go to most recent revision | Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT LIBRARY COMPONENTS                          --
--                                                                          --
--                       A D A . C O N T A I N E R S .                      --
--       H A S H _ T A B L E S . G E N E R I C _ O P E R A T I O N S        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2004-2005, Free Software Foundation, Inc.         --
--                                                                          --
-- 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 2,  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.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  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  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- This unit was originally developed by Matthew J Heaney.                  --
------------------------------------------------------------------------------
 
--  This body needs commenting ???
 
with Ada.Containers.Prime_Numbers;
with Ada.Unchecked_Deallocation;
 
with System;  use type System.Address;
 
package body Ada.Containers.Hash_Tables.Generic_Operations is
 
   procedure Free is
     new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);
 
   ------------
   -- Adjust --
   ------------
 
   procedure Adjust (HT : in out Hash_Table_Type) is
      Src_Buckets : constant Buckets_Access := HT.Buckets;
      N           : constant Count_Type := HT.Length;
      Src_Node    : Node_Access;
      Dst_Prev    : Node_Access;
 
   begin
      HT.Buckets := null;
      HT.Length := 0;
 
      if N = 0 then
         return;
      end if;
 
      HT.Buckets := new Buckets_Type (Src_Buckets'Range);
      --  TODO: allocate minimum size req'd.  (See note below.)
 
      --  NOTE: see note below about these comments.
      --  Probably we have to duplicate the Size (Src), too, in order
      --  to guarantee that
 
      --    Dst := Src;
      --    Dst = Src is true
 
      --  The only quirk is that we depend on the hash value of a dst key
      --  to be the same as the src key from which it was copied.
      --  If we relax the requirement that the hash value must be the
      --  same, then of course we can't guarantee that following
      --  assignment that Dst = Src is true ???
      --
      --  NOTE: 17 Apr 2005
      --  What I said above is no longer true.  The semantics of (map) equality
      --  changed, such that we use key in the left map to look up the
      --  equivalent key in the right map, and then compare the elements (using
      --  normal equality) of the equivalent keys.  So it doesn't matter that
      --  the maps have different capacities (i.e. the hash tables have
      --  different lengths), since we just look up the key, irrespective of
      --  its map's hash table length.  All the RM says we're required to do
      --  it arrange for the target map to "=" the source map following an
      --  assignment (that is, following an Adjust), so it doesn't matter
      --  what the capacity of the target map is.  What I'll probably do is
      --  allocate a new hash table that has the minimum size necessary,
      --  instead of allocating a new hash table whose size exactly matches
      --  that of the source.  (See the assignment that immediately precedes
      --  these comments.)  What we really need is a special Assign operation
      --  (not unlike what we have already for Vector) that allows the user to
      --  choose the capacity of the target.
      --  END NOTE.
 
      for Src_Index in Src_Buckets'Range loop
         Src_Node := Src_Buckets (Src_Index);
 
         if Src_Node /= null then
            declare
               Dst_Node : constant Node_Access := Copy_Node (Src_Node);
 
               --   See note above
 
               pragma Assert (Index (HT, Dst_Node) = Src_Index);
 
            begin
               HT.Buckets (Src_Index) := Dst_Node;
               HT.Length := HT.Length + 1;
 
               Dst_Prev := Dst_Node;
            end;
 
            Src_Node := Next (Src_Node);
            while Src_Node /= null loop
               declare
                  Dst_Node : constant Node_Access := Copy_Node (Src_Node);
 
                  --  See note above
 
                  pragma Assert (Index (HT, Dst_Node) = Src_Index);
 
               begin
                  Set_Next (Node => Dst_Prev, Next => Dst_Node);
                  HT.Length := HT.Length + 1;
 
                  Dst_Prev := Dst_Node;
               end;
 
               Src_Node := Next (Src_Node);
            end loop;
         end if;
      end loop;
 
      pragma Assert (HT.Length = N);
   end Adjust;
 
   --------------
   -- Capacity --
   --------------
 
   function Capacity (HT : Hash_Table_Type) return Count_Type is
   begin
      if HT.Buckets = null then
         return 0;
      end if;
 
      return HT.Buckets'Length;
   end Capacity;
 
   -----------
   -- Clear --
   -----------
 
   procedure Clear (HT : in out Hash_Table_Type) is
      Index : Hash_Type := 0;
      Node  : Node_Access;
 
   begin
      if HT.Busy > 0 then
         raise Program_Error;
      end if;
 
      while HT.Length > 0 loop
         while HT.Buckets (Index) = null loop
            Index := Index + 1;
         end loop;
 
         declare
            Bucket : Node_Access renames HT.Buckets (Index);
         begin
            loop
               Node := Bucket;
               Bucket := Next (Bucket);
               HT.Length := HT.Length - 1;
               Free (Node);
               exit when Bucket = null;
            end loop;
         end;
      end loop;
   end Clear;
 
   ---------------------------
   -- Delete_Node_Sans_Free --
   ---------------------------
 
   procedure Delete_Node_Sans_Free
     (HT : in out Hash_Table_Type;
      X  : Node_Access)
   is
      pragma Assert (X /= null);
 
      Indx : Hash_Type;
      Prev : Node_Access;
      Curr : Node_Access;
 
   begin
      if HT.Length = 0 then
         raise Program_Error;
      end if;
 
      Indx := Index (HT, X);
      Prev := HT.Buckets (Indx);
 
      if Prev = null then
         raise Program_Error;
      end if;
 
      if Prev = X then
         HT.Buckets (Indx) := Next (Prev);
         HT.Length := HT.Length - 1;
         return;
      end if;
 
      if HT.Length = 1 then
         raise Program_Error;
      end if;
 
      loop
         Curr := Next (Prev);
 
         if Curr = null then
            raise Program_Error;
         end if;
 
         if Curr = X then
            Set_Next (Node => Prev, Next => Next (Curr));
            HT.Length := HT.Length - 1;
            return;
         end if;
 
         Prev := Curr;
      end loop;
   end Delete_Node_Sans_Free;
 
   --------------
   -- Finalize --
   --------------
 
   procedure Finalize (HT : in out Hash_Table_Type) is
   begin
      Clear (HT);
      Free (HT.Buckets);
   end Finalize;
 
   -----------
   -- First --
   -----------
 
   function First (HT : Hash_Table_Type) return Node_Access is
      Indx : Hash_Type;
 
   begin
      if HT.Length = 0 then
         return null;
      end if;
 
      Indx := HT.Buckets'First;
      loop
         if HT.Buckets (Indx) /= null then
            return HT.Buckets (Indx);
         end if;
 
         Indx := Indx + 1;
      end loop;
   end First;
 
   ---------------------
   -- Free_Hash_Table --
   ---------------------
 
   procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
      Node : Node_Access;
 
   begin
      if Buckets = null then
         return;
      end if;
 
      for J in Buckets'Range loop
         while Buckets (J) /= null loop
            Node := Buckets (J);
            Buckets (J) := Next (Node);
            Free (Node);
         end loop;
      end loop;
 
      Free (Buckets);
   end Free_Hash_Table;
 
   -------------------
   -- Generic_Equal --
   -------------------
 
   function Generic_Equal
     (L, R : Hash_Table_Type) return Boolean is
 
      L_Index : Hash_Type;
      L_Node  : Node_Access;
 
      N : Count_Type;
 
   begin
      if L'Address = R'Address then
         return True;
      end if;
 
      if L.Length /= R.Length then
         return False;
      end if;
 
      if L.Length = 0 then
         return True;
      end if;
 
      L_Index := 0;
 
      loop
         L_Node := L.Buckets (L_Index);
         exit when L_Node /= null;
         L_Index := L_Index + 1;
      end loop;
 
      N := L.Length;
 
      loop
         if not Find (HT => R, Key => L_Node) then
            return False;
         end if;
 
         N := N - 1;
 
         L_Node := Next (L_Node);
 
         if L_Node = null then
            if N = 0 then
               return True;
            end if;
 
            loop
               L_Index := L_Index + 1;
               L_Node := L.Buckets (L_Index);
               exit when L_Node /= null;
            end loop;
         end if;
      end loop;
   end Generic_Equal;
 
   -----------------------
   -- Generic_Iteration --
   -----------------------
 
   procedure Generic_Iteration (HT : Hash_Table_Type) is
      Busy : Natural renames HT'Unrestricted_Access.all.Busy;
 
   begin
      if HT.Length = 0 then
         return;
      end if;
 
      Busy := Busy + 1;
 
      declare
         Node : Node_Access;
      begin
         for Indx in HT.Buckets'Range loop
            Node := HT.Buckets (Indx);
            while Node /= null loop
               Process (Node);
               Node := Next (Node);
            end loop;
         end loop;
      exception
         when others =>
            Busy := Busy - 1;
            raise;
      end;
 
      Busy := Busy - 1;
   end Generic_Iteration;
 
   ------------------
   -- Generic_Read --
   ------------------
 
   procedure Generic_Read
     (Stream : access Root_Stream_Type'Class;
      HT     : out Hash_Table_Type)
   is
      X, Y : Node_Access;
 
      Last, I : Hash_Type;
      N, M    : Count_Type'Base;
 
   begin
      Clear (HT);
 
      Hash_Type'Read (Stream, Last);
 
      Count_Type'Base'Read (Stream, N);
      pragma Assert (N >= 0);
 
      if N = 0 then
         return;
      end if;
 
      if HT.Buckets = null
        or else HT.Buckets'Last /= Last
      then
         Free (HT.Buckets);
         HT.Buckets := new Buckets_Type (0 .. Last);
      end if;
 
      --  TODO: should we rewrite this algorithm so that it doesn't
      --  depend on preserving the exactly length of the hash table
      --  array?  We would prefer to not have to (re)allocate a
      --  buckets array (the array that HT already has might be large
      --  enough), and to not have to stream the count of the number
      --  of nodes in each bucket.  The algorithm below is vestigial,
      --  as it was written prior to the meeting in Palma, when the
      --  semantics of equality were changed (and which obviated the
      --  need to preserve the hash table length).
 
      loop
         Hash_Type'Read (Stream, I);
         pragma Assert (I in HT.Buckets'Range);
         pragma Assert (HT.Buckets (I) = null);
 
         Count_Type'Base'Read (Stream, M);
         pragma Assert (M >= 1);
         pragma Assert (M <= N);
 
         HT.Buckets (I) := New_Node (Stream);
         pragma Assert (HT.Buckets (I) /= null);
         pragma Assert (Next (HT.Buckets (I)) = null);
 
         Y := HT.Buckets (I);
 
         HT.Length := HT.Length + 1;
 
         for J in Count_Type range 2 .. M loop
            X := New_Node (Stream);
            pragma Assert (X /= null);
            pragma Assert (Next (X) = null);
 
            Set_Next (Node => Y, Next => X);
            Y := X;
 
            HT.Length := HT.Length + 1;
         end loop;
 
         N := N - M;
 
         exit when N = 0;
      end loop;
   end Generic_Read;
 
   -------------------
   -- Generic_Write --
   -------------------
 
   procedure Generic_Write
     (Stream : access Root_Stream_Type'Class;
      HT     : Hash_Table_Type)
   is
      M : Count_Type'Base;
      X : Node_Access;
 
   begin
      if HT.Buckets = null then
         Hash_Type'Write (Stream, 0);
      else
         Hash_Type'Write (Stream, HT.Buckets'Last);
      end if;
 
      Count_Type'Base'Write (Stream, HT.Length);
 
      if HT.Length = 0 then
         return;
      end if;
 
      --  TODO: see note in Generic_Read???
 
      for Indx in HT.Buckets'Range loop
         X := HT.Buckets (Indx);
 
         if X /= null then
            M := 1;
            loop
               X := Next (X);
               exit when X = null;
               M := M + 1;
            end loop;
 
            Hash_Type'Write (Stream, Indx);
            Count_Type'Base'Write (Stream, M);
 
            X := HT.Buckets (Indx);
            for J in Count_Type range 1 .. M loop
               Write (Stream, X);
               X := Next (X);
            end loop;
 
            pragma Assert (X = null);
         end if;
      end loop;
   end Generic_Write;
 
   -----------
   -- Index --
   -----------
 
   function Index
     (Buckets : Buckets_Type;
      Node    : Node_Access) return Hash_Type is
   begin
      return Hash_Node (Node) mod Buckets'Length;
   end Index;
 
   function Index
     (Hash_Table : Hash_Table_Type;
      Node       : Node_Access) return Hash_Type is
   begin
      return Index (Hash_Table.Buckets.all, Node);
   end Index;
 
   ----------
   -- Move --
   ----------
 
   procedure Move (Target, Source : in out Hash_Table_Type) is
   begin
      if Target'Address = Source'Address then
         return;
      end if;
 
      if Source.Busy > 0 then
         raise Program_Error;
      end if;
 
      Clear (Target);
 
      declare
         Buckets : constant Buckets_Access := Target.Buckets;
      begin
         Target.Buckets := Source.Buckets;
         Source.Buckets := Buckets;
      end;
 
      Target.Length := Source.Length;
      Source.Length := 0;
   end Move;
 
   ----------
   -- Next --
   ----------
 
   function Next
     (HT   : Hash_Table_Type;
      Node : Node_Access) return Node_Access
   is
      Result : Node_Access := Next (Node);
 
   begin
      if Result /= null then
         return Result;
      end if;
 
      for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop
         Result := HT.Buckets (Indx);
 
         if Result /= null then
            return Result;
         end if;
      end loop;
 
      return null;
   end Next;
 
   ----------------------
   -- Reserve_Capacity --
   ----------------------
 
   procedure Reserve_Capacity
     (HT : in out Hash_Table_Type;
      N  : Count_Type)
   is
      NN : Hash_Type;
 
   begin
      if HT.Buckets = null then
         if N > 0 then
            NN := Prime_Numbers.To_Prime (N);
            HT.Buckets := new Buckets_Type (0 .. NN - 1);
         end if;
 
         return;
      end if;
 
      if HT.Length = 0 then
         if N = 0 then
            Free (HT.Buckets);
            return;
         end if;
 
         if N = HT.Buckets'Length then
            return;
         end if;
 
         NN := Prime_Numbers.To_Prime (N);
 
         if NN = HT.Buckets'Length then
            return;
         end if;
 
         declare
            X : Buckets_Access := HT.Buckets;
         begin
            HT.Buckets := new Buckets_Type (0 .. NN - 1);
            Free (X);
         end;
 
         return;
      end if;
 
      if N = HT.Buckets'Length then
         return;
      end if;
 
      if N < HT.Buckets'Length then
         if HT.Length >= HT.Buckets'Length then
            return;
         end if;
 
         NN := Prime_Numbers.To_Prime (HT.Length);
 
         if NN >= HT.Buckets'Length then
            return;
         end if;
 
      else
         NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
 
         if NN = HT.Buckets'Length then -- can't expand any more
            return;
         end if;
      end if;
 
      if HT.Busy > 0 then
         raise Program_Error;
      end if;
 
      Rehash : declare
         Dst_Buckets : Buckets_Access := new Buckets_Type (0 .. NN - 1);
         Src_Buckets : Buckets_Access := HT.Buckets;
 
         L : Count_Type renames HT.Length;
         LL : constant Count_Type := L;
 
         Src_Index : Hash_Type := Src_Buckets'First;
 
      begin
         while L > 0 loop
            declare
               Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
 
            begin
               while Src_Bucket /= null loop
                  declare
                     Src_Node : constant Node_Access := Src_Bucket;
 
                     Dst_Index : constant Hash_Type :=
                       Index (Dst_Buckets.all, Src_Node);
 
                     Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
 
                  begin
                     Src_Bucket := Next (Src_Node);
 
                     Set_Next (Src_Node, Dst_Bucket);
 
                     Dst_Bucket := Src_Node;
                  end;
 
                  pragma Assert (L > 0);
                  L := L - 1;
               end loop;
            exception
               when others =>
                  --  If there's an error computing a hash value during a
                  --  rehash, then AI-302 says the nodes "become lost."  The
                  --  issue is whether to actually deallocate these lost nodes,
                  --  since they might be designated by extant cursors.  Here
                  --  we decide to deallocate the nodes, since it's better to
                  --  solve real problems (storage consumption) rather than
                  --  imaginary ones (the user might, or might not, dereference
                  --  a cursor designating a node that has been deallocated),
                  --  and because we have a way to vet a dangling cursor
                  --  reference anyway, and hence can actually detect the
                  --  problem.
 
                  for Dst_Index in Dst_Buckets'Range loop
                     declare
                        B : Node_Access renames Dst_Buckets (Dst_Index);
                        X : Node_Access;
                     begin
                        while B /= null loop
                           X := B;
                           B := Next (X);
                           Free (X);
                        end loop;
                     end;
                  end loop;
 
                  Free (Dst_Buckets);
                  raise Program_Error;
            end;
 
            Src_Index := Src_Index + 1;
         end loop;
 
         HT.Buckets := Dst_Buckets;
         HT.Length := LL;
 
         Free (Src_Buckets);
      end Rehash;
   end Reserve_Capacity;
 
end Ada.Containers.Hash_Tables.Generic_Operations;

Browse

Tools

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [ada/] [a-chtgop.adb] - Blame information for rev 20

Line No.	Rev	Author	Line
1	12	jlechner	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT LIBRARY COMPONENTS --`
4			`-- --`
5			`-- A D A . C O N T A I N E R S . --`
6			`-- H A S H _ T A B L E S . G E N E R I C _ O P E R A T I O N S --`
7			`-- --`
8			`-- B o d y --`
9			`-- --`
10			`-- Copyright (C) 2004-2005, Free Software Foundation, Inc. --`
11			`-- --`
12			`-- GNAT is free software; you can redistribute it and/or modify it under --`
13			`-- terms of the GNU General Public License as published by the Free Soft- --`
14			`-- ware Foundation; either version 2, or (at your option) any later ver- --`
15			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
16			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
17			`-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --`
18			`-- for more details. You should have received a copy of the GNU General --`
19			`-- Public License distributed with GNAT; see file COPYING. If not, write --`
20			`-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --`
21			`-- Boston, MA 02110-1301, USA. --`
22			`-- --`
23			`-- As a special exception, if other files instantiate generics from this --`
24			`-- unit, or you link this unit with other files to produce an executable, --`
25			`-- this unit does not by itself cause the resulting executable to be --`
26			`-- covered by the GNU General Public License. This exception does not --`
27			`-- however invalidate any other reasons why the executable file might be --`
28			`-- covered by the GNU Public License. --`
29			`-- --`
30			`-- This unit was originally developed by Matthew J Heaney. --`
31			`------------------------------------------------------------------------------`
32
33			`-- This body needs commenting ???`
34
35			`with Ada.Containers.Prime_Numbers;`
36			`with Ada.Unchecked_Deallocation;`
37
38			`with System; use type System.Address;`
39
40			`package body Ada.Containers.Hash_Tables.Generic_Operations is`
41
42			`procedure Free is`
43			`new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);`
44
45			`------------`
46			`-- Adjust --`
47			`------------`
48
49			`procedure Adjust (HT : in out Hash_Table_Type) is`
50			`Src_Buckets : constant Buckets_Access := HT.Buckets;`
51			`N : constant Count_Type := HT.Length;`
52			`Src_Node : Node_Access;`
53			`Dst_Prev : Node_Access;`
54
55			`begin`
56			`HT.Buckets := null;`
57			`HT.Length := 0;`
58
59			`if N = 0 then`
60			`return;`
61			`end if;`
62
63			`HT.Buckets := new Buckets_Type (Src_Buckets'Range);`
64			`-- TODO: allocate minimum size req'd. (See note below.)`
65
66			`-- NOTE: see note below about these comments.`
67			`-- Probably we have to duplicate the Size (Src), too, in order`
68			`-- to guarantee that`
69
70			`-- Dst := Src;`
71			`-- Dst = Src is true`
72
73			`-- The only quirk is that we depend on the hash value of a dst key`
74			`-- to be the same as the src key from which it was copied.`
75			`-- If we relax the requirement that the hash value must be the`
76			`-- same, then of course we can't guarantee that following`
77			`-- assignment that Dst = Src is true ???`
78			`--`
79			`-- NOTE: 17 Apr 2005`
80			`-- What I said above is no longer true. The semantics of (map) equality`
81			`-- changed, such that we use key in the left map to look up the`
82			`-- equivalent key in the right map, and then compare the elements (using`
83			`-- normal equality) of the equivalent keys. So it doesn't matter that`
84			`-- the maps have different capacities (i.e. the hash tables have`
85			`-- different lengths), since we just look up the key, irrespective of`
86			`-- its map's hash table length. All the RM says we're required to do`
87			`-- it arrange for the target map to "=" the source map following an`
88			`-- assignment (that is, following an Adjust), so it doesn't matter`
89			`-- what the capacity of the target map is. What I'll probably do is`
90			`-- allocate a new hash table that has the minimum size necessary,`
91			`-- instead of allocating a new hash table whose size exactly matches`
92			`-- that of the source. (See the assignment that immediately precedes`
93			`-- these comments.) What we really need is a special Assign operation`
94			`-- (not unlike what we have already for Vector) that allows the user to`
95			`-- choose the capacity of the target.`
96			`-- END NOTE.`
97
98			`for Src_Index in Src_Buckets'Range loop`
99			`Src_Node := Src_Buckets (Src_Index);`
100
101			`if Src_Node /= null then`
102			`declare`
103			`Dst_Node : constant Node_Access := Copy_Node (Src_Node);`
104
105			`-- See note above`
106
107			`pragma Assert (Index (HT, Dst_Node) = Src_Index);`
108
109			`begin`
110			`HT.Buckets (Src_Index) := Dst_Node;`
111			`HT.Length := HT.Length + 1;`
112
113			`Dst_Prev := Dst_Node;`
114			`end;`
115
116			`Src_Node := Next (Src_Node);`
117			`while Src_Node /= null loop`
118			`declare`
119			`Dst_Node : constant Node_Access := Copy_Node (Src_Node);`
120
121			`-- See note above`
122
123			`pragma Assert (Index (HT, Dst_Node) = Src_Index);`
124
125			`begin`
126			`Set_Next (Node => Dst_Prev, Next => Dst_Node);`
127			`HT.Length := HT.Length + 1;`
128
129			`Dst_Prev := Dst_Node;`
130			`end;`
131
132			`Src_Node := Next (Src_Node);`
133			`end loop;`
134			`end if;`
135			`end loop;`
136
137			`pragma Assert (HT.Length = N);`
138			`end Adjust;`
139
140			`--------------`
141			`-- Capacity --`
142			`--------------`
143
144			`function Capacity (HT : Hash_Table_Type) return Count_Type is`
145			`begin`
146			`if HT.Buckets = null then`
147			`return 0;`
148			`end if;`
149
150			`return HT.Buckets'Length;`
151			`end Capacity;`
152
153			`-----------`
154			`-- Clear --`
155			`-----------`
156
157			`procedure Clear (HT : in out Hash_Table_Type) is`
158			`Index : Hash_Type := 0;`
159			`Node : Node_Access;`
160
161			`begin`
162			`if HT.Busy > 0 then`
163			`raise Program_Error;`
164			`end if;`
165
166			`while HT.Length > 0 loop`
167			`while HT.Buckets (Index) = null loop`
168			`Index := Index + 1;`
169			`end loop;`
170
171			`declare`
172			`Bucket : Node_Access renames HT.Buckets (Index);`
173			`begin`
174			`loop`
175			`Node := Bucket;`
176			`Bucket := Next (Bucket);`
177			`HT.Length := HT.Length - 1;`
178			`Free (Node);`
179			`exit when Bucket = null;`
180			`end loop;`
181			`end;`
182			`end loop;`
183			`end Clear;`
184
185			`---------------------------`
186			`-- Delete_Node_Sans_Free --`
187			`---------------------------`
188
189			`procedure Delete_Node_Sans_Free`
190			`(HT : in out Hash_Table_Type;`
191			`X : Node_Access)`
192			`is`
193			`pragma Assert (X /= null);`
194
195			`Indx : Hash_Type;`
196			`Prev : Node_Access;`
197			`Curr : Node_Access;`
198
199			`begin`
200			`if HT.Length = 0 then`
201			`raise Program_Error;`
202			`end if;`
203
204			`Indx := Index (HT, X);`
205			`Prev := HT.Buckets (Indx);`
206
207			`if Prev = null then`
208			`raise Program_Error;`
209			`end if;`
210
211			`if Prev = X then`
212			`HT.Buckets (Indx) := Next (Prev);`
213			`HT.Length := HT.Length - 1;`
214			`return;`
215			`end if;`
216
217			`if HT.Length = 1 then`
218			`raise Program_Error;`
219			`end if;`
220
221			`loop`
222			`Curr := Next (Prev);`
223
224			`if Curr = null then`
225			`raise Program_Error;`
226			`end if;`
227
228			`if Curr = X then`
229			`Set_Next (Node => Prev, Next => Next (Curr));`
230			`HT.Length := HT.Length - 1;`
231			`return;`
232			`end if;`
233
234			`Prev := Curr;`
235			`end loop;`
236			`end Delete_Node_Sans_Free;`
237
238			`--------------`
239			`-- Finalize --`
240			`--------------`
241
242			`procedure Finalize (HT : in out Hash_Table_Type) is`
243			`begin`
244			`Clear (HT);`
245			`Free (HT.Buckets);`
246			`end Finalize;`
247
248			`-----------`
249			`-- First --`
250			`-----------`
251
252			`function First (HT : Hash_Table_Type) return Node_Access is`
253			`Indx : Hash_Type;`
254
255			`begin`
256			`if HT.Length = 0 then`
257			`return null;`
258			`end if;`
259
260			`Indx := HT.Buckets'First;`
261			`loop`
262			`if HT.Buckets (Indx) /= null then`
263			`return HT.Buckets (Indx);`
264			`end if;`
265
266			`Indx := Indx + 1;`
267			`end loop;`
268			`end First;`
269
270			`---------------------`
271			`-- Free_Hash_Table --`
272			`---------------------`
273
274			`procedure Free_Hash_Table (Buckets : in out Buckets_Access) is`
275			`Node : Node_Access;`
276
277			`begin`
278			`if Buckets = null then`
279			`return;`
280			`end if;`
281
282			`for J in Buckets'Range loop`
283			`while Buckets (J) /= null loop`
284			`Node := Buckets (J);`
285			`Buckets (J) := Next (Node);`
286			`Free (Node);`
287			`end loop;`
288			`end loop;`
289
290			`Free (Buckets);`
291			`end Free_Hash_Table;`
292
293			`-------------------`
294			`-- Generic_Equal --`
295			`-------------------`
296
297			`function Generic_Equal`
298			`(L, R : Hash_Table_Type) return Boolean is`
299
300			`L_Index : Hash_Type;`
301			`L_Node : Node_Access;`
302
303			`N : Count_Type;`
304
305			`begin`
306			`if L'Address = R'Address then`
307			`return True;`
308			`end if;`
309
310			`if L.Length /= R.Length then`
311			`return False;`
312			`end if;`
313
314			`if L.Length = 0 then`
315			`return True;`
316			`end if;`
317
318			`L_Index := 0;`
319
320			`loop`
321			`L_Node := L.Buckets (L_Index);`
322			`exit when L_Node /= null;`
323			`L_Index := L_Index + 1;`
324			`end loop;`
325
326			`N := L.Length;`
327
328			`loop`
329			`if not Find (HT => R, Key => L_Node) then`
330			`return False;`
331			`end if;`
332
333			`N := N - 1;`
334
335			`L_Node := Next (L_Node);`
336
337			`if L_Node = null then`
338			`if N = 0 then`
339			`return True;`
340			`end if;`
341
342			`loop`
343			`L_Index := L_Index + 1;`
344			`L_Node := L.Buckets (L_Index);`
345			`exit when L_Node /= null;`
346			`end loop;`
347			`end if;`
348			`end loop;`
349			`end Generic_Equal;`
350
351			`-----------------------`
352			`-- Generic_Iteration --`
353			`-----------------------`
354
355			`procedure Generic_Iteration (HT : Hash_Table_Type) is`
356			`Busy : Natural renames HT'Unrestricted_Access.all.Busy;`
357
358			`begin`
359			`if HT.Length = 0 then`
360			`return;`
361			`end if;`
362
363			`Busy := Busy + 1;`
364
365			`declare`
366			`Node : Node_Access;`
367			`begin`
368			`for Indx in HT.Buckets'Range loop`
369			`Node := HT.Buckets (Indx);`
370			`while Node /= null loop`
371			`Process (Node);`
372			`Node := Next (Node);`
373			`end loop;`
374			`end loop;`
375			`exception`
376			`when others =>`
377			`Busy := Busy - 1;`
378			`raise;`
379			`end;`
380
381			`Busy := Busy - 1;`
382			`end Generic_Iteration;`
383
384			`------------------`
385			`-- Generic_Read --`
386			`------------------`
387
388			`procedure Generic_Read`
389			`(Stream : access Root_Stream_Type'Class;`
390			`HT : out Hash_Table_Type)`
391			`is`
392			`X, Y : Node_Access;`
393
394			`Last, I : Hash_Type;`
395			`N, M : Count_Type'Base;`
396
397			`begin`
398			`Clear (HT);`
399
400			`Hash_Type'Read (Stream, Last);`
401
402			`Count_Type'Base'Read (Stream, N);`
403			`pragma Assert (N >= 0);`
404
405			`if N = 0 then`
406			`return;`
407			`end if;`
408
409			`if HT.Buckets = null`
410			`or else HT.Buckets'Last /= Last`
411			`then`
412			`Free (HT.Buckets);`
413			`HT.Buckets := new Buckets_Type (0 .. Last);`
414			`end if;`
415
416			`-- TODO: should we rewrite this algorithm so that it doesn't`
417			`-- depend on preserving the exactly length of the hash table`
418			`-- array? We would prefer to not have to (re)allocate a`
419			`-- buckets array (the array that HT already has might be large`
420			`-- enough), and to not have to stream the count of the number`
421			`-- of nodes in each bucket. The algorithm below is vestigial,`
422			`-- as it was written prior to the meeting in Palma, when the`
423			`-- semantics of equality were changed (and which obviated the`
424			`-- need to preserve the hash table length).`
425
426			`loop`
427			`Hash_Type'Read (Stream, I);`
428			`pragma Assert (I in HT.Buckets'Range);`
429			`pragma Assert (HT.Buckets (I) = null);`
430
431			`Count_Type'Base'Read (Stream, M);`
432			`pragma Assert (M >= 1);`
433			`pragma Assert (M <= N);`
434
435			`HT.Buckets (I) := New_Node (Stream);`
436			`pragma Assert (HT.Buckets (I) /= null);`
437			`pragma Assert (Next (HT.Buckets (I)) = null);`
438
439			`Y := HT.Buckets (I);`
440
441			`HT.Length := HT.Length + 1;`
442
443			`for J in Count_Type range 2 .. M loop`
444			`X := New_Node (Stream);`
445			`pragma Assert (X /= null);`
446			`pragma Assert (Next (X) = null);`
447
448			`Set_Next (Node => Y, Next => X);`
449			`Y := X;`
450
451			`HT.Length := HT.Length + 1;`
452			`end loop;`
453
454			`N := N - M;`
455
456			`exit when N = 0;`
457			`end loop;`
458			`end Generic_Read;`
459
460			`-------------------`
461			`-- Generic_Write --`
462			`-------------------`
463
464			`procedure Generic_Write`
465			`(Stream : access Root_Stream_Type'Class;`
466			`HT : Hash_Table_Type)`
467			`is`
468			`M : Count_Type'Base;`
469			`X : Node_Access;`
470
471			`begin`
472			`if HT.Buckets = null then`
473			`Hash_Type'Write (Stream, 0);`
474			`else`
475			`Hash_Type'Write (Stream, HT.Buckets'Last);`
476			`end if;`
477
478			`Count_Type'Base'Write (Stream, HT.Length);`
479
480			`if HT.Length = 0 then`
481			`return;`
482			`end if;`
483
484			`-- TODO: see note in Generic_Read???`
485
486			`for Indx in HT.Buckets'Range loop`
487			`X := HT.Buckets (Indx);`
488
489			`if X /= null then`
490			`M := 1;`
491			`loop`
492			`X := Next (X);`
493			`exit when X = null;`
494			`M := M + 1;`
495			`end loop;`
496
497			`Hash_Type'Write (Stream, Indx);`
498			`Count_Type'Base'Write (Stream, M);`
499
500			`X := HT.Buckets (Indx);`
501			`for J in Count_Type range 1 .. M loop`
502			`Write (Stream, X);`
503			`X := Next (X);`
504			`end loop;`
505
506			`pragma Assert (X = null);`
507			`end if;`
508			`end loop;`
509			`end Generic_Write;`
510
511			`-----------`
512			`-- Index --`
513			`-----------`
514
515			`function Index`
516			`(Buckets : Buckets_Type;`
517			`Node : Node_Access) return Hash_Type is`
518			`begin`
519			`return Hash_Node (Node) mod Buckets'Length;`
520			`end Index;`
521
522			`function Index`
523			`(Hash_Table : Hash_Table_Type;`
524			`Node : Node_Access) return Hash_Type is`
525			`begin`
526			`return Index (Hash_Table.Buckets.all, Node);`
527			`end Index;`
528
529			`----------`
530			`-- Move --`
531			`----------`
532
533			`procedure Move (Target, Source : in out Hash_Table_Type) is`
534			`begin`
535			`if Target'Address = Source'Address then`
536			`return;`
537			`end if;`
538
539			`if Source.Busy > 0 then`
540			`raise Program_Error;`
541			`end if;`
542
543			`Clear (Target);`
544
545			`declare`
546			`Buckets : constant Buckets_Access := Target.Buckets;`
547			`begin`
548			`Target.Buckets := Source.Buckets;`
549			`Source.Buckets := Buckets;`
550			`end;`
551
552			`Target.Length := Source.Length;`
553			`Source.Length := 0;`
554			`end Move;`
555
556			`----------`
557			`-- Next --`
558			`----------`
559
560			`function Next`
561			`(HT : Hash_Table_Type;`
562			`Node : Node_Access) return Node_Access`
563			`is`
564			`Result : Node_Access := Next (Node);`
565
566			`begin`
567			`if Result /= null then`
568			`return Result;`
569			`end if;`
570
571			`for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop`
572			`Result := HT.Buckets (Indx);`
573
574			`if Result /= null then`
575			`return Result;`
576			`end if;`
577			`end loop;`
578
579			`return null;`
580			`end Next;`
581
582			`----------------------`
583			`-- Reserve_Capacity --`
584			`----------------------`
585
586			`procedure Reserve_Capacity`
587			`(HT : in out Hash_Table_Type;`
588			`N : Count_Type)`
589			`is`
590			`NN : Hash_Type;`
591
592			`begin`
593			`if HT.Buckets = null then`
594			`if N > 0 then`
595			`NN := Prime_Numbers.To_Prime (N);`
596			`HT.Buckets := new Buckets_Type (0 .. NN - 1);`
597			`end if;`
598
599			`return;`
600			`end if;`
601
602			`if HT.Length = 0 then`
603			`if N = 0 then`
604			`Free (HT.Buckets);`
605			`return;`
606			`end if;`
607
608			`if N = HT.Buckets'Length then`
609			`return;`
610			`end if;`
611
612			`NN := Prime_Numbers.To_Prime (N);`
613
614			`if NN = HT.Buckets'Length then`
615			`return;`
616			`end if;`
617
618			`declare`
619			`X : Buckets_Access := HT.Buckets;`
620			`begin`
621			`HT.Buckets := new Buckets_Type (0 .. NN - 1);`
622			`Free (X);`
623			`end;`
624
625			`return;`
626			`end if;`
627
628			`if N = HT.Buckets'Length then`
629			`return;`
630			`end if;`
631
632			`if N < HT.Buckets'Length then`
633			`if HT.Length >= HT.Buckets'Length then`
634			`return;`
635			`end if;`
636
637			`NN := Prime_Numbers.To_Prime (HT.Length);`
638
639			`if NN >= HT.Buckets'Length then`
640			`return;`
641			`end if;`
642
643			`else`
644			`NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));`
645
646			`if NN = HT.Buckets'Length then -- can't expand any more`
647			`return;`
648			`end if;`
649			`end if;`
650
651			`if HT.Busy > 0 then`
652			`raise Program_Error;`
653			`end if;`
654
655			`Rehash : declare`
656			`Dst_Buckets : Buckets_Access := new Buckets_Type (0 .. NN - 1);`
657			`Src_Buckets : Buckets_Access := HT.Buckets;`
658
659			`L : Count_Type renames HT.Length;`
660			`LL : constant Count_Type := L;`
661
662			`Src_Index : Hash_Type := Src_Buckets'First;`
663
664			`begin`
665			`while L > 0 loop`
666			`declare`
667			`Src_Bucket : Node_Access renames Src_Buckets (Src_Index);`
668
669			`begin`
670			`while Src_Bucket /= null loop`
671			`declare`
672			`Src_Node : constant Node_Access := Src_Bucket;`
673
674			`Dst_Index : constant Hash_Type :=`
675			`Index (Dst_Buckets.all, Src_Node);`
676
677			`Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);`
678
679			`begin`
680			`Src_Bucket := Next (Src_Node);`
681
682			`Set_Next (Src_Node, Dst_Bucket);`
683
684			`Dst_Bucket := Src_Node;`
685			`end;`
686
687			`pragma Assert (L > 0);`
688			`L := L - 1;`
689			`end loop;`
690			`exception`
691			`when others =>`
692			`-- If there's an error computing a hash value during a`
693			`-- rehash, then AI-302 says the nodes "become lost." The`
694			`-- issue is whether to actually deallocate these lost nodes,`
695			`-- since they might be designated by extant cursors. Here`
696			`-- we decide to deallocate the nodes, since it's better to`
697			`-- solve real problems (storage consumption) rather than`
698			`-- imaginary ones (the user might, or might not, dereference`
699			`-- a cursor designating a node that has been deallocated),`
700			`-- and because we have a way to vet a dangling cursor`
701			`-- reference anyway, and hence can actually detect the`
702			`-- problem.`
703
704			`for Dst_Index in Dst_Buckets'Range loop`
705			`declare`
706			`B : Node_Access renames Dst_Buckets (Dst_Index);`
707			`X : Node_Access;`
708			`begin`
709			`while B /= null loop`
710			`X := B;`
711			`B := Next (X);`
712			`Free (X);`
713			`end loop;`
714			`end;`
715			`end loop;`
716
717			`Free (Dst_Buckets);`
718			`raise Program_Error;`
719			`end;`
720
721			`Src_Index := Src_Index + 1;`
722			`end loop;`
723
724			`HT.Buckets := Dst_Buckets;`
725			`HT.Length := LL;`
726
727			`Free (Src_Buckets);`
728			`end Rehash;`
729			`end Reserve_Capacity;`
730
731			`end Ada.Containers.Hash_Tables.Generic_Operations;`