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);
45 -----------------------
46 -- Local Subprograms --
47 -----------------------
50 (HT : in out Hash_Table_Type;
57 procedure Adjust (HT : in out Hash_Table_Type) is
58 Src_Buckets : constant Buckets_Access := HT.Buckets;
59 N : constant Count_Type := HT.Length;
60 Src_Node : Node_Access;
61 Dst_Prev : Node_Access;
71 HT.Buckets := new Buckets_Type (Src_Buckets'Range);
72 -- TODO: allocate minimum size req'd. (See note below.)
74 -- NOTE: see note below about these comments.
75 -- Probably we have to duplicate the Size (Src), too, in order
81 -- The only quirk is that we depend on the hash value of a dst key
82 -- to be the same as the src key from which it was copied.
83 -- If we relax the requirement that the hash value must be the
84 -- same, then of course we can't guarantee that following
85 -- assignment that Dst = Src is true ???
88 -- What I said above is no longer true. The semantics of (map) equality
89 -- changed, such that we use key in the left map to look up the
90 -- equivalent key in the right map, and then compare the elements (using
91 -- normal equality) of the equivalent keys. So it doesn't matter that
92 -- the maps have different capacities (i.e. the hash tables have
93 -- different lengths), since we just look up the key, irrespective of
94 -- its map's hash table length. All the RM says we're required to do
95 -- it arrange for the target map to "=" the source map following an
96 -- assignment (that is, following an Adjust), so it doesn't matter
97 -- what the capacity of the target map is. What I'll probably do is
98 -- allocate a new hash table that has the minimum size necessary,
99 -- instead of allocating a new hash table whose size exactly matches
100 -- that of the source. (See the assignment that immediately precedes
101 -- these comments.) What we really need is a special Assign operation
102 -- (not unlike what we have already for Vector) that allows the user to
103 -- choose the capacity of the target.
106 for Src_Index in Src_Buckets'Range loop
107 Src_Node := Src_Buckets (Src_Index);
109 if Src_Node /= null then
111 Dst_Node : constant Node_Access := Copy_Node (Src_Node);
115 pragma Assert (Index (HT, Dst_Node) = Src_Index);
118 HT.Buckets (Src_Index) := Dst_Node;
119 HT.Length := HT.Length + 1;
121 Dst_Prev := Dst_Node;
124 Src_Node := Next (Src_Node);
125 while Src_Node /= null loop
127 Dst_Node : constant Node_Access := Copy_Node (Src_Node);
131 pragma Assert (Index (HT, Dst_Node) = Src_Index);
134 Set_Next (Node => Dst_Prev, Next => Dst_Node);
135 HT.Length := HT.Length + 1;
137 Dst_Prev := Dst_Node;
140 Src_Node := Next (Src_Node);
145 pragma Assert (HT.Length = N);
152 function Capacity (HT : Hash_Table_Type) return Count_Type is
154 if HT.Buckets = null then
158 return HT.Buckets'Length;
165 procedure Clear (HT : in out Hash_Table_Type) is
166 Index : Hash_Type := 0;
174 while HT.Length > 0 loop
175 while HT.Buckets (Index) = null loop
180 Bucket : Node_Access renames HT.Buckets (Index);
184 Bucket := Next (Bucket);
185 HT.Length := HT.Length - 1;
187 exit when Bucket = null;
193 ---------------------------
194 -- Delete_Node_Sans_Free --
195 ---------------------------
197 procedure Delete_Node_Sans_Free
198 (HT : in out Hash_Table_Type;
201 pragma Assert (X /= null);
208 if HT.Length = 0 then
212 Indx := Index (HT, X);
213 Prev := HT.Buckets (Indx);
220 HT.Buckets (Indx) := Next (Prev);
221 HT.Length := HT.Length - 1;
225 if HT.Length = 1 then
237 Set_Next (Node => Prev, Next => Next (Curr));
238 HT.Length := HT.Length - 1;
244 end Delete_Node_Sans_Free;
250 procedure Finalize (HT : in out Hash_Table_Type) is
260 function First (HT : Hash_Table_Type) return Node_Access is
264 if HT.Length = 0 then
268 Indx := HT.Buckets'First;
270 if HT.Buckets (Indx) /= null then
271 return HT.Buckets (Indx);
278 ---------------------
279 -- Free_Hash_Table --
280 ---------------------
282 procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
286 if Buckets = null then
290 for J in Buckets'Range loop
291 while Buckets (J) /= null loop
293 Buckets (J) := Next (Node);
305 function Generic_Equal
306 (L, R : Hash_Table_Type) return Boolean is
309 L_Node : Node_Access;
314 if L'Address = R'Address then
318 if L.Length /= R.Length then
329 L_Node := L.Buckets (L_Index);
330 exit when L_Node /= null;
331 L_Index := L_Index + 1;
337 if not Find (HT => R, Key => L_Node) then
343 L_Node := Next (L_Node);
345 if L_Node = null then
351 L_Index := L_Index + 1;
352 L_Node := L.Buckets (L_Index);
353 exit when L_Node /= null;
359 -----------------------
360 -- Generic_Iteration --
361 -----------------------
363 procedure Generic_Iteration (HT : Hash_Table_Type) is
364 Busy : Natural renames HT'Unrestricted_Access.all.Busy;
367 if HT.Length = 0 then
376 for Indx in HT.Buckets'Range loop
377 Node := HT.Buckets (Indx);
378 while Node /= null loop
390 end Generic_Iteration;
396 procedure Generic_Read
397 (Stream : access Root_Stream_Type'Class;
398 HT : out Hash_Table_Type)
403 N, M : Count_Type'Base;
409 B : Buckets_Access := HT.Buckets;
413 Free (B); -- can this fail???
416 Hash_Type'Read (Stream, Last);
418 -- TODO: don't immediately deallocate the buckets array we
419 -- already have. Instead, allocate a new buckets array only
420 -- if it needs to expanded because of the value of Last.
423 HT.Buckets := new Buckets_Type (0 .. Last);
426 Count_Type'Base'Read (Stream, N);
427 pragma Assert (N >= 0);
429 Hash_Type'Read (Stream, I);
430 pragma Assert (I in HT.Buckets'Range);
431 pragma Assert (HT.Buckets (I) = null);
433 Count_Type'Base'Read (Stream, M);
434 pragma Assert (M >= 1);
435 pragma Assert (M <= N);
437 HT.Buckets (I) := New_Node (Stream);
438 pragma Assert (HT.Buckets (I) /= null);
439 pragma Assert (Next (HT.Buckets (I)) = null);
443 HT.Length := HT.Length + 1;
445 for J in Count_Type range 2 .. M loop
446 X := New_Node (Stream);
447 pragma Assert (X /= null);
448 pragma Assert (Next (X) = null);
450 Set_Next (Node => Y, Next => X);
453 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 for Indx in HT.Buckets'Range loop
485 X := HT.Buckets (Indx);
495 Hash_Type'Write (Stream, Indx);
496 Count_Type'Base'Write (Stream, M);
498 X := HT.Buckets (Indx);
499 for J in Count_Type range 1 .. M loop
504 pragma Assert (X = null);
514 (Buckets : Buckets_Type;
515 Node : Node_Access) return Hash_Type is
517 return Hash_Node (Node) mod Buckets'Length;
521 (Hash_Table : Hash_Table_Type;
522 Node : Node_Access) return Hash_Type is
524 return Index (Hash_Table.Buckets.all, Node);
531 procedure Move (Target, Source : in out Hash_Table_Type) is
533 if Target'Address = Source'Address then
537 if Source.Busy > 0 then
544 Buckets : constant Buckets_Access := Target.Buckets;
546 Target.Buckets := Source.Buckets;
547 Source.Buckets := Buckets;
550 Target.Length := Source.Length;
559 (HT : Hash_Table_Type;
560 Node : Node_Access) return Node_Access
562 Result : Node_Access := Next (Node);
565 if Result /= null then
569 for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop
570 Result := HT.Buckets (Indx);
572 if Result /= null then
585 (HT : in out Hash_Table_Type;
588 subtype Buckets_Range is Hash_Type range 0 .. Size - 1;
590 Dst_Buckets : Buckets_Access := new Buckets_Type (Buckets_Range);
591 Src_Buckets : Buckets_Access := HT.Buckets;
593 L : Count_Type renames HT.Length;
594 LL : constant Count_Type := L;
597 if Src_Buckets = null then
598 pragma Assert (L = 0);
599 HT.Buckets := Dst_Buckets;
604 HT.Buckets := Dst_Buckets;
609 -- We might want to change this to iter from 1 .. L instead ???
611 for Src_Index in Src_Buckets'Range loop
614 Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
616 while Src_Bucket /= null loop
618 Src_Node : constant Node_Access := Src_Bucket;
619 Dst_Index : constant Hash_Type :=
620 Index (Dst_Buckets.all, Src_Node);
621 Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
623 Src_Bucket := Next (Src_Node);
624 Set_Next (Src_Node, Dst_Bucket);
625 Dst_Bucket := Src_Node;
628 pragma Assert (L > 0);
636 -- NOTE: see todo below.
637 -- Not clear that we can deallocate the nodes,
638 -- because they may be designated by outstanding
639 -- iterators. Which means they're now lost... ???
641 -- for J in NB'Range loop
643 -- Dst : Node_Access renames NB (J);
646 -- while Dst /= null loop
648 -- Dst := Succ (Dst);
655 -- What I should do instead is go ahead and deallocate the
656 -- nodes, since when assertions are enabled, we vet the
657 -- cursors, and we modify the state of a node enough when
658 -- it is deallocated in order to detect mischief.
662 raise; -- TODO: raise Program_Error instead
670 pragma Assert (L = 0);
672 HT.Buckets := Dst_Buckets;
678 ----------------------
679 -- Reserve_Capacity --
680 ----------------------
682 procedure Reserve_Capacity
683 (HT : in out Hash_Table_Type;
690 if HT.Length = 0 then
693 elsif HT.Length < HT.Buckets'Length then
694 NN := Prime_Numbers.To_Prime (HT.Length);
696 -- ASSERT: NN >= HT.Length
698 if NN < HT.Buckets'Length then
703 Rehash (HT, Size => NN);
710 if HT.Buckets = null then
711 NN := Prime_Numbers.To_Prime (N);
715 Rehash (HT, Size => NN);
719 if N <= HT.Length then
720 if HT.Length >= HT.Buckets'Length then
724 NN := Prime_Numbers.To_Prime (HT.Length);
726 -- ASSERT: NN >= HT.Length
728 if NN < HT.Buckets'Length then
733 Rehash (HT, Size => NN);
739 -- ASSERT: N > HT.Length
741 if N = HT.Buckets'Length then
745 NN := Prime_Numbers.To_Prime (N);
748 -- ASSERT: NN > HT.Length
750 if NN /= HT.Buckets'Length then
755 Rehash (HT, Size => NN);
757 end Reserve_Capacity;
759 end Ada.Containers.Hash_Tables.Generic_Operations;