1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
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 --
10 -- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
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. --
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. --
30 -- This unit was originally developed by Matthew J Heaney. --
31 ------------------------------------------------------------------------------
33 -- This body needs commenting ???
35 with Ada.Containers.Prime_Numbers;
36 with Ada.Unchecked_Deallocation;
38 with System; use type System.Address;
40 package body Ada.Containers.Hash_Tables.Generic_Operations is
43 new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);
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;
63 HT.Buckets := new Buckets_Type (Src_Buckets'Range);
64 -- TODO: allocate minimum size req'd. (See note below.)
66 -- NOTE: see note below about these comments.
67 -- Probably we have to duplicate the Size (Src), too, in order
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 ???
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.
98 for Src_Index in Src_Buckets'Range loop
99 Src_Node := Src_Buckets (Src_Index);
101 if Src_Node /= null then
103 Dst_Node : constant Node_Access := Copy_Node (Src_Node);
107 pragma Assert (Index (HT, Dst_Node) = Src_Index);
110 HT.Buckets (Src_Index) := Dst_Node;
111 HT.Length := HT.Length + 1;
113 Dst_Prev := Dst_Node;
116 Src_Node := Next (Src_Node);
117 while Src_Node /= null loop
119 Dst_Node : constant Node_Access := Copy_Node (Src_Node);
123 pragma Assert (Index (HT, Dst_Node) = Src_Index);
126 Set_Next (Node => Dst_Prev, Next => Dst_Node);
127 HT.Length := HT.Length + 1;
129 Dst_Prev := Dst_Node;
132 Src_Node := Next (Src_Node);
137 pragma Assert (HT.Length = N);
144 function Capacity (HT : Hash_Table_Type) return Count_Type is
146 if HT.Buckets = null then
150 return HT.Buckets'Length;
157 procedure Clear (HT : in out Hash_Table_Type) is
158 Index : Hash_Type := 0;
166 while HT.Length > 0 loop
167 while HT.Buckets (Index) = null loop
172 Bucket : Node_Access renames HT.Buckets (Index);
176 Bucket := Next (Bucket);
177 HT.Length := HT.Length - 1;
179 exit when Bucket = null;
185 ---------------------------
186 -- Delete_Node_Sans_Free --
187 ---------------------------
189 procedure Delete_Node_Sans_Free
190 (HT : in out Hash_Table_Type;
193 pragma Assert (X /= null);
200 if HT.Length = 0 then
204 Indx := Index (HT, X);
205 Prev := HT.Buckets (Indx);
212 HT.Buckets (Indx) := Next (Prev);
213 HT.Length := HT.Length - 1;
217 if HT.Length = 1 then
229 Set_Next (Node => Prev, Next => Next (Curr));
230 HT.Length := HT.Length - 1;
236 end Delete_Node_Sans_Free;
242 procedure Finalize (HT : in out Hash_Table_Type) is
252 function First (HT : Hash_Table_Type) return Node_Access is
256 if HT.Length = 0 then
260 Indx := HT.Buckets'First;
262 if HT.Buckets (Indx) /= null then
263 return HT.Buckets (Indx);
270 ---------------------
271 -- Free_Hash_Table --
272 ---------------------
274 procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
278 if Buckets = null then
282 for J in Buckets'Range loop
283 while Buckets (J) /= null loop
285 Buckets (J) := Next (Node);
297 function Generic_Equal
298 (L, R : Hash_Table_Type) return Boolean is
301 L_Node : Node_Access;
306 if L'Address = R'Address then
310 if L.Length /= R.Length then
321 L_Node := L.Buckets (L_Index);
322 exit when L_Node /= null;
323 L_Index := L_Index + 1;
329 if not Find (HT => R, Key => L_Node) then
335 L_Node := Next (L_Node);
337 if L_Node = null then
343 L_Index := L_Index + 1;
344 L_Node := L.Buckets (L_Index);
345 exit when L_Node /= null;
351 -----------------------
352 -- Generic_Iteration --
353 -----------------------
355 procedure Generic_Iteration (HT : Hash_Table_Type) is
356 Busy : Natural renames HT'Unrestricted_Access.all.Busy;
359 if HT.Length = 0 then
368 for Indx in HT.Buckets'Range loop
369 Node := HT.Buckets (Indx);
370 while Node /= null loop
382 end Generic_Iteration;
388 procedure Generic_Read
389 (Stream : access Root_Stream_Type'Class;
390 HT : out Hash_Table_Type)
395 N, M : Count_Type'Base;
400 Hash_Type'Read (Stream, Last);
402 Count_Type'Base'Read (Stream, N);
403 pragma Assert (N >= 0);
410 or else HT.Buckets'Last /= Last
413 HT.Buckets := new Buckets_Type (0 .. Last);
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).
427 Hash_Type'Read (Stream, I);
428 pragma Assert (I in HT.Buckets'Range);
429 pragma Assert (HT.Buckets (I) = null);
431 Count_Type'Base'Read (Stream, M);
432 pragma Assert (M >= 1);
433 pragma Assert (M <= N);
435 HT.Buckets (I) := New_Node (Stream);
436 pragma Assert (HT.Buckets (I) /= null);
437 pragma Assert (Next (HT.Buckets (I)) = null);
441 HT.Length := HT.Length + 1;
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);
448 Set_Next (Node => Y, Next => X);
451 HT.Length := HT.Length + 1;
464 procedure Generic_Write
465 (Stream : access Root_Stream_Type'Class;
466 HT : Hash_Table_Type)
472 if HT.Buckets = null then
473 Hash_Type'Write (Stream, 0);
475 Hash_Type'Write (Stream, HT.Buckets'Last);
478 Count_Type'Base'Write (Stream, HT.Length);
480 if HT.Length = 0 then
484 -- TODO: see note in Generic_Read???
486 for Indx in HT.Buckets'Range loop
487 X := HT.Buckets (Indx);
497 Hash_Type'Write (Stream, Indx);
498 Count_Type'Base'Write (Stream, M);
500 X := HT.Buckets (Indx);
501 for J in Count_Type range 1 .. M loop
506 pragma Assert (X = null);
516 (Buckets : Buckets_Type;
517 Node : Node_Access) return Hash_Type is
519 return Hash_Node (Node) mod Buckets'Length;
523 (Hash_Table : Hash_Table_Type;
524 Node : Node_Access) return Hash_Type is
526 return Index (Hash_Table.Buckets.all, Node);
533 procedure Move (Target, Source : in out Hash_Table_Type) is
535 if Target'Address = Source'Address then
539 if Source.Busy > 0 then
546 Buckets : constant Buckets_Access := Target.Buckets;
548 Target.Buckets := Source.Buckets;
549 Source.Buckets := Buckets;
552 Target.Length := Source.Length;
561 (HT : Hash_Table_Type;
562 Node : Node_Access) return Node_Access
564 Result : Node_Access := Next (Node);
567 if Result /= null then
571 for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop
572 Result := HT.Buckets (Indx);
574 if Result /= null then
582 ----------------------
583 -- Reserve_Capacity --
584 ----------------------
586 procedure Reserve_Capacity
587 (HT : in out Hash_Table_Type;
593 if HT.Buckets = null then
595 NN := Prime_Numbers.To_Prime (N);
596 HT.Buckets := new Buckets_Type (0 .. NN - 1);
602 if HT.Length = 0 then
608 if N = HT.Buckets'Length then
612 NN := Prime_Numbers.To_Prime (N);
614 if NN = HT.Buckets'Length then
619 X : Buckets_Access := HT.Buckets;
621 HT.Buckets := new Buckets_Type (0 .. NN - 1);
628 if N = HT.Buckets'Length then
632 if N < HT.Buckets'Length then
633 if HT.Length >= HT.Buckets'Length then
637 NN := Prime_Numbers.To_Prime (HT.Length);
639 if NN >= HT.Buckets'Length then
644 NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
646 if NN = HT.Buckets'Length then -- can't expand any more
656 Dst_Buckets : Buckets_Access := new Buckets_Type (0 .. NN - 1);
657 Src_Buckets : Buckets_Access := HT.Buckets;
659 L : Count_Type renames HT.Length;
660 LL : constant Count_Type := L;
662 Src_Index : Hash_Type := Src_Buckets'First;
667 Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
670 while Src_Bucket /= null loop
672 Src_Node : constant Node_Access := Src_Bucket;
674 Dst_Index : constant Hash_Type :=
675 Index (Dst_Buckets.all, Src_Node);
677 Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
680 Src_Bucket := Next (Src_Node);
682 Set_Next (Src_Node, Dst_Bucket);
684 Dst_Bucket := Src_Node;
687 pragma Assert (L > 0);
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
704 for Dst_Index in Dst_Buckets'Range loop
706 B : Node_Access renames Dst_Buckets (Dst_Index);
721 Src_Index := Src_Index + 1;
724 HT.Buckets := Dst_Buckets;
729 end Reserve_Capacity;
731 end Ada.Containers.Hash_Tables.Generic_Operations;