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-2007, 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 with Ada.Containers.Prime_Numbers;
34 with Ada.Unchecked_Deallocation;
36 with System; use type System.Address;
38 package body Ada.Containers.Hash_Tables.Generic_Operations is
40 type Buckets_Allocation is access all Buckets_Type;
41 -- Used for allocation and deallocation (see New_Buckets and
42 -- Free_Buckets). This is necessary because Buckets_Access has an empty
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 -- Technically it isn't necessary to allocate the exact same length
64 -- buckets array, because our only requirement is that following
65 -- assignment the source and target containers compare equal (that is,
66 -- operator "=" returns True). We can satisfy this requirement with any
67 -- hash table length, but we decide here to match the length of the
68 -- source table. This has the benefit that when iterating, elements of
69 -- the target are delivered in the exact same order as for the source.
71 HT.Buckets := New_Buckets (Length => Src_Buckets'Length);
73 for Src_Index in Src_Buckets'Range loop
74 Src_Node := Src_Buckets (Src_Index);
76 if Src_Node /= null then
78 Dst_Node : constant Node_Access := Copy_Node (Src_Node);
82 pragma Assert (Index (HT, Dst_Node) = Src_Index);
85 HT.Buckets (Src_Index) := Dst_Node;
86 HT.Length := HT.Length + 1;
91 Src_Node := Next (Src_Node);
92 while Src_Node /= null loop
94 Dst_Node : constant Node_Access := Copy_Node (Src_Node);
98 pragma Assert (Index (HT, Dst_Node) = Src_Index);
101 Set_Next (Node => Dst_Prev, Next => Dst_Node);
102 HT.Length := HT.Length + 1;
104 Dst_Prev := Dst_Node;
107 Src_Node := Next (Src_Node);
112 pragma Assert (HT.Length = N);
119 function Capacity (HT : Hash_Table_Type) return Count_Type is
121 if HT.Buckets = null then
125 return HT.Buckets'Length;
132 procedure Clear (HT : in out Hash_Table_Type) is
133 Index : Hash_Type := 0;
138 raise Program_Error with
139 "attempt to tamper with elements (container is busy)";
142 while HT.Length > 0 loop
143 while HT.Buckets (Index) = null loop
148 Bucket : Node_Access renames HT.Buckets (Index);
152 Bucket := Next (Bucket);
153 HT.Length := HT.Length - 1;
155 exit when Bucket = null;
161 ---------------------------
162 -- Delete_Node_Sans_Free --
163 ---------------------------
165 procedure Delete_Node_Sans_Free
166 (HT : in out Hash_Table_Type;
169 pragma Assert (X /= null);
176 if HT.Length = 0 then
177 raise Program_Error with
178 "attempt to delete node from empty hashed container";
181 Indx := Index (HT, X);
182 Prev := HT.Buckets (Indx);
185 raise Program_Error with
186 "attempt to delete node from empty hash bucket";
190 HT.Buckets (Indx) := Next (Prev);
191 HT.Length := HT.Length - 1;
195 if HT.Length = 1 then
196 raise Program_Error with
197 "attempt to delete node not in its proper hash bucket";
204 raise Program_Error with
205 "attempt to delete node not in its proper hash bucket";
209 Set_Next (Node => Prev, Next => Next (Curr));
210 HT.Length := HT.Length - 1;
216 end Delete_Node_Sans_Free;
222 procedure Finalize (HT : in out Hash_Table_Type) is
225 Free_Buckets (HT.Buckets);
232 function First (HT : Hash_Table_Type) return Node_Access is
236 if HT.Length = 0 then
240 Indx := HT.Buckets'First;
242 if HT.Buckets (Indx) /= null then
243 return HT.Buckets (Indx);
254 procedure Free_Buckets (Buckets : in out Buckets_Access) is
256 new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Allocation);
259 -- Buckets must have been created by New_Buckets. Here, we convert back
260 -- to the Buckets_Allocation type, and do the free on that.
262 Free (Buckets_Allocation (Buckets));
265 ---------------------
266 -- Free_Hash_Table --
267 ---------------------
269 procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
273 if Buckets = null then
277 for J in Buckets'Range loop
278 while Buckets (J) /= null loop
280 Buckets (J) := Next (Node);
285 Free_Buckets (Buckets);
292 function Generic_Equal
293 (L, R : Hash_Table_Type) return Boolean
296 L_Node : Node_Access;
301 if L'Address = R'Address then
305 if L.Length /= R.Length then
313 -- Find the first node of hash table L
317 L_Node := L.Buckets (L_Index);
318 exit when L_Node /= null;
319 L_Index := L_Index + 1;
322 -- For each node of hash table L, search for an equivalent node in hash
327 if not Find (HT => R, Key => L_Node) then
333 L_Node := Next (L_Node);
335 if L_Node = null then
336 -- We have exhausted the nodes in this bucket
342 -- Find the next bucket
345 L_Index := L_Index + 1;
346 L_Node := L.Buckets (L_Index);
347 exit when L_Node /= null;
353 -----------------------
354 -- Generic_Iteration --
355 -----------------------
357 procedure Generic_Iteration (HT : Hash_Table_Type) is
361 if HT.Length = 0 then
365 for Indx in HT.Buckets'Range loop
366 Node := HT.Buckets (Indx);
367 while Node /= null loop
372 end Generic_Iteration;
378 procedure Generic_Read
379 (Stream : not null access Root_Stream_Type'Class;
380 HT : out Hash_Table_Type)
388 Count_Type'Base'Read (Stream, N);
391 raise Program_Error with "stream appears to be corrupt";
398 -- The RM does not specify whether or how the capacity changes when a
399 -- hash table is streamed in. Therefore we decide here to allocate a new
400 -- buckets array only when it's necessary to preserve representation
404 or else HT.Buckets'Length < N
406 Free_Buckets (HT.Buckets);
407 NN := Prime_Numbers.To_Prime (N);
408 HT.Buckets := New_Buckets (Length => NN);
413 Node : constant Node_Access := New_Node (Stream);
414 Indx : constant Hash_Type := Index (HT, Node);
415 B : Node_Access renames HT.Buckets (Indx);
417 Set_Next (Node => Node, Next => B);
421 HT.Length := HT.Length + 1;
429 procedure Generic_Write
430 (Stream : not null access Root_Stream_Type'Class;
431 HT : Hash_Table_Type)
433 procedure Write (Node : Node_Access);
434 pragma Inline (Write);
436 procedure Write is new Generic_Iteration (Write);
442 procedure Write (Node : Node_Access) is
444 Write (Stream, Node);
448 -- See Generic_Read for an explanation of why we do not stream out the
449 -- buckets array length too.
451 Count_Type'Base'Write (Stream, HT.Length);
460 (Buckets : Buckets_Type;
461 Node : Node_Access) return Hash_Type is
463 return Hash_Node (Node) mod Buckets'Length;
467 (Hash_Table : Hash_Table_Type;
468 Node : Node_Access) return Hash_Type is
470 return Index (Hash_Table.Buckets.all, Node);
477 procedure Move (Target, Source : in out Hash_Table_Type) is
479 if Target'Address = Source'Address then
483 if Source.Busy > 0 then
484 raise Program_Error with
485 "attempt to tamper with elements (container is busy)";
491 Buckets : constant Buckets_Access := Target.Buckets;
493 Target.Buckets := Source.Buckets;
494 Source.Buckets := Buckets;
497 Target.Length := Source.Length;
505 function New_Buckets (Length : Hash_Type) return Buckets_Access is
506 subtype Rng is Hash_Type range 0 .. Length - 1;
509 -- Allocate in Buckets_Allocation'Storage_Pool, then convert to
512 return Buckets_Access (Buckets_Allocation'(new Buckets_Type (Rng)));
520 (HT : Hash_Table_Type;
521 Node : Node_Access) return Node_Access
523 Result : Node_Access := Next (Node);
526 if Result /= null then
530 for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop
531 Result := HT.Buckets (Indx);
533 if Result /= null then
541 ----------------------
542 -- Reserve_Capacity --
543 ----------------------
545 procedure Reserve_Capacity
546 (HT : in out Hash_Table_Type;
552 if HT.Buckets = null then
554 NN := Prime_Numbers.To_Prime (N);
555 HT.Buckets := New_Buckets (Length => NN);
561 if HT.Length = 0 then
563 -- This is the easy case. There are no nodes, so no rehashing is
564 -- necessary. All we need to do is allocate a new buckets array
565 -- having a length implied by the specified capacity. (We say
566 -- "implied by" because bucket arrays are always allocated with a
567 -- length that corresponds to a prime number.)
570 Free_Buckets (HT.Buckets);
574 if N = HT.Buckets'Length then
578 NN := Prime_Numbers.To_Prime (N);
580 if NN = HT.Buckets'Length then
585 X : Buckets_Access := HT.Buckets;
587 HT.Buckets := New_Buckets (Length => NN);
594 if N = HT.Buckets'Length then
598 if N < HT.Buckets'Length then
600 -- This is a request to contract the buckets array. The amount of
601 -- contraction is bounded in order to preserve the invariant that the
602 -- buckets array length is never smaller than the number of elements
603 -- (the load factor is 1).
605 if HT.Length >= HT.Buckets'Length then
609 NN := Prime_Numbers.To_Prime (HT.Length);
611 if NN >= HT.Buckets'Length then
616 NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
618 if NN = HT.Buckets'Length then -- can't expand any more
624 raise Program_Error with
625 "attempt to tamper with elements (container is busy)";
629 Dst_Buckets : Buckets_Access := New_Buckets (Length => NN);
630 Src_Buckets : Buckets_Access := HT.Buckets;
632 L : Count_Type renames HT.Length;
633 LL : constant Count_Type := L;
635 Src_Index : Hash_Type := Src_Buckets'First;
640 Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
643 while Src_Bucket /= null loop
645 Src_Node : constant Node_Access := Src_Bucket;
647 Dst_Index : constant Hash_Type :=
648 Index (Dst_Buckets.all, Src_Node);
650 Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
653 Src_Bucket := Next (Src_Node);
655 Set_Next (Src_Node, Dst_Bucket);
657 Dst_Bucket := Src_Node;
660 pragma Assert (L > 0);
665 -- If there's an error computing a hash value during a
666 -- rehash, then AI-302 says the nodes "become lost." The
667 -- issue is whether to actually deallocate these lost nodes,
668 -- since they might be designated by extant cursors. Here
669 -- we decide to deallocate the nodes, since it's better to
670 -- solve real problems (storage consumption) rather than
671 -- imaginary ones (the user might, or might not, dereference
672 -- a cursor designating a node that has been deallocated),
673 -- and because we have a way to vet a dangling cursor
674 -- reference anyway, and hence can actually detect the
677 for Dst_Index in Dst_Buckets'Range loop
679 B : Node_Access renames Dst_Buckets (Dst_Index);
690 Free_Buckets (Dst_Buckets);
691 raise Program_Error with
692 "hash function raised exception during rehash";
695 Src_Index := Src_Index + 1;
698 HT.Buckets := Dst_Buckets;
701 Free_Buckets (Src_Buckets);
703 end Reserve_Capacity;
705 end Ada.Containers.Hash_Tables.Generic_Operations;