1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS --
9 -- Copyright (C) 2004-2009, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada.Containers.Prime_Numbers;
31 with Ada.Unchecked_Deallocation;
33 with System; use type System.Address;
35 package body Ada.Containers.Hash_Tables.Generic_Operations is
37 type Buckets_Allocation is access all Buckets_Type;
38 -- Used for allocation and deallocation (see New_Buckets and Free_Buckets).
39 -- This is necessary because Buckets_Access has an empty storage pool.
45 procedure Adjust (HT : in out Hash_Table_Type) is
46 Src_Buckets : constant Buckets_Access := HT.Buckets;
47 N : constant Count_Type := HT.Length;
48 Src_Node : Node_Access;
49 Dst_Prev : Node_Access;
59 -- Technically it isn't necessary to allocate the exact same length
60 -- buckets array, because our only requirement is that following
61 -- assignment the source and target containers compare equal (that is,
62 -- operator "=" returns True). We can satisfy this requirement with any
63 -- hash table length, but we decide here to match the length of the
64 -- source table. This has the benefit that when iterating, elements of
65 -- the target are delivered in the exact same order as for the source.
67 HT.Buckets := New_Buckets (Length => Src_Buckets'Length);
69 for Src_Index in Src_Buckets'Range loop
70 Src_Node := Src_Buckets (Src_Index);
72 if Src_Node /= null then
74 Dst_Node : constant Node_Access := Copy_Node (Src_Node);
78 pragma Assert (Index (HT, Dst_Node) = Src_Index);
81 HT.Buckets (Src_Index) := Dst_Node;
82 HT.Length := HT.Length + 1;
87 Src_Node := Next (Src_Node);
88 while Src_Node /= null loop
90 Dst_Node : constant Node_Access := Copy_Node (Src_Node);
94 pragma Assert (Index (HT, Dst_Node) = Src_Index);
97 Set_Next (Node => Dst_Prev, Next => Dst_Node);
98 HT.Length := HT.Length + 1;
100 Dst_Prev := Dst_Node;
103 Src_Node := Next (Src_Node);
108 pragma Assert (HT.Length = N);
115 function Capacity (HT : Hash_Table_Type) return Count_Type is
117 if HT.Buckets = null then
121 return HT.Buckets'Length;
128 procedure Clear (HT : in out Hash_Table_Type) is
129 Index : Hash_Type := 0;
134 raise Program_Error with
135 "attempt to tamper with elements (container is busy)";
138 while HT.Length > 0 loop
139 while HT.Buckets (Index) = null loop
144 Bucket : Node_Access renames HT.Buckets (Index);
148 Bucket := Next (Bucket);
149 HT.Length := HT.Length - 1;
151 exit when Bucket = null;
157 ---------------------------
158 -- Delete_Node_Sans_Free --
159 ---------------------------
161 procedure Delete_Node_Sans_Free
162 (HT : in out Hash_Table_Type;
165 pragma Assert (X /= null);
172 if HT.Length = 0 then
173 raise Program_Error with
174 "attempt to delete node from empty hashed container";
177 Indx := Index (HT, X);
178 Prev := HT.Buckets (Indx);
181 raise Program_Error with
182 "attempt to delete node from empty hash bucket";
186 HT.Buckets (Indx) := Next (Prev);
187 HT.Length := HT.Length - 1;
191 if HT.Length = 1 then
192 raise Program_Error with
193 "attempt to delete node not in its proper hash bucket";
200 raise Program_Error with
201 "attempt to delete node not in its proper hash bucket";
205 Set_Next (Node => Prev, Next => Next (Curr));
206 HT.Length := HT.Length - 1;
212 end Delete_Node_Sans_Free;
218 procedure Finalize (HT : in out Hash_Table_Type) is
221 Free_Buckets (HT.Buckets);
228 function First (HT : Hash_Table_Type) return Node_Access is
232 if HT.Length = 0 then
236 Indx := HT.Buckets'First;
238 if HT.Buckets (Indx) /= null then
239 return HT.Buckets (Indx);
250 procedure Free_Buckets (Buckets : in out Buckets_Access) is
252 new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Allocation);
255 -- Buckets must have been created by New_Buckets. Here, we convert back
256 -- to the Buckets_Allocation type, and do the free on that.
258 Free (Buckets_Allocation (Buckets));
261 ---------------------
262 -- Free_Hash_Table --
263 ---------------------
265 procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
269 if Buckets = null then
273 for J in Buckets'Range loop
274 while Buckets (J) /= null loop
276 Buckets (J) := Next (Node);
281 Free_Buckets (Buckets);
288 function Generic_Equal
289 (L, R : Hash_Table_Type) return Boolean
292 L_Node : Node_Access;
297 if L'Address = R'Address then
301 if L.Length /= R.Length then
309 -- Find the first node of hash table L
313 L_Node := L.Buckets (L_Index);
314 exit when L_Node /= null;
315 L_Index := L_Index + 1;
318 -- For each node of hash table L, search for an equivalent node in hash
323 if not Find (HT => R, Key => L_Node) then
329 L_Node := Next (L_Node);
331 if L_Node = null then
332 -- We have exhausted the nodes in this bucket
338 -- Find the next bucket
341 L_Index := L_Index + 1;
342 L_Node := L.Buckets (L_Index);
343 exit when L_Node /= null;
349 -----------------------
350 -- Generic_Iteration --
351 -----------------------
353 procedure Generic_Iteration (HT : Hash_Table_Type) is
357 if HT.Length = 0 then
361 for Indx in HT.Buckets'Range loop
362 Node := HT.Buckets (Indx);
363 while Node /= null loop
368 end Generic_Iteration;
374 procedure Generic_Read
375 (Stream : not null access Root_Stream_Type'Class;
376 HT : out Hash_Table_Type)
384 Count_Type'Base'Read (Stream, N);
387 raise Program_Error with "stream appears to be corrupt";
394 -- The RM does not specify whether or how the capacity changes when a
395 -- hash table is streamed in. Therefore we decide here to allocate a new
396 -- buckets array only when it's necessary to preserve representation
400 or else HT.Buckets'Length < N
402 Free_Buckets (HT.Buckets);
403 NN := Prime_Numbers.To_Prime (N);
404 HT.Buckets := New_Buckets (Length => NN);
409 Node : constant Node_Access := New_Node (Stream);
410 Indx : constant Hash_Type := Index (HT, Node);
411 B : Node_Access renames HT.Buckets (Indx);
413 Set_Next (Node => Node, Next => B);
417 HT.Length := HT.Length + 1;
425 procedure Generic_Write
426 (Stream : not null access Root_Stream_Type'Class;
427 HT : Hash_Table_Type)
429 procedure Write (Node : Node_Access);
430 pragma Inline (Write);
432 procedure Write is new Generic_Iteration (Write);
438 procedure Write (Node : Node_Access) is
440 Write (Stream, Node);
444 -- See Generic_Read for an explanation of why we do not stream out the
445 -- buckets array length too.
447 Count_Type'Base'Write (Stream, HT.Length);
456 (Buckets : Buckets_Type;
457 Node : Node_Access) return Hash_Type is
459 return Hash_Node (Node) mod Buckets'Length;
463 (Hash_Table : Hash_Table_Type;
464 Node : Node_Access) return Hash_Type is
466 return Index (Hash_Table.Buckets.all, Node);
473 procedure Move (Target, Source : in out Hash_Table_Type) is
475 if Target'Address = Source'Address then
479 if Source.Busy > 0 then
480 raise Program_Error with
481 "attempt to tamper with elements (container is busy)";
487 Buckets : constant Buckets_Access := Target.Buckets;
489 Target.Buckets := Source.Buckets;
490 Source.Buckets := Buckets;
493 Target.Length := Source.Length;
501 function New_Buckets (Length : Hash_Type) return Buckets_Access is
502 subtype Rng is Hash_Type range 0 .. Length - 1;
505 -- Allocate in Buckets_Allocation'Storage_Pool, then convert to
508 return Buckets_Access (Buckets_Allocation'(new Buckets_Type (Rng)));
516 (HT : Hash_Table_Type;
517 Node : Node_Access) return Node_Access
519 Result : Node_Access := Next (Node);
522 if Result /= null then
526 for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop
527 Result := HT.Buckets (Indx);
529 if Result /= null then
537 ----------------------
538 -- Reserve_Capacity --
539 ----------------------
541 procedure Reserve_Capacity
542 (HT : in out Hash_Table_Type;
548 if HT.Buckets = null then
550 NN := Prime_Numbers.To_Prime (N);
551 HT.Buckets := New_Buckets (Length => NN);
557 if HT.Length = 0 then
559 -- This is the easy case. There are no nodes, so no rehashing is
560 -- necessary. All we need to do is allocate a new buckets array
561 -- having a length implied by the specified capacity. (We say
562 -- "implied by" because bucket arrays are always allocated with a
563 -- length that corresponds to a prime number.)
566 Free_Buckets (HT.Buckets);
570 if N = HT.Buckets'Length then
574 NN := Prime_Numbers.To_Prime (N);
576 if NN = HT.Buckets'Length then
581 X : Buckets_Access := HT.Buckets;
582 pragma Warnings (Off, X);
584 HT.Buckets := New_Buckets (Length => NN);
591 if N = HT.Buckets'Length then
595 if N < HT.Buckets'Length then
597 -- This is a request to contract the buckets array. The amount of
598 -- contraction is bounded in order to preserve the invariant that the
599 -- buckets array length is never smaller than the number of elements
600 -- (the load factor is 1).
602 if HT.Length >= HT.Buckets'Length then
606 NN := Prime_Numbers.To_Prime (HT.Length);
608 if NN >= HT.Buckets'Length then
613 NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
615 if NN = HT.Buckets'Length then -- can't expand any more
621 raise Program_Error with
622 "attempt to tamper with elements (container is busy)";
626 Dst_Buckets : Buckets_Access := New_Buckets (Length => NN);
627 Src_Buckets : Buckets_Access := HT.Buckets;
628 pragma Warnings (Off, Src_Buckets);
630 L : Count_Type renames HT.Length;
631 LL : constant Count_Type := L;
633 Src_Index : Hash_Type := Src_Buckets'First;
638 Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
641 while Src_Bucket /= null loop
643 Src_Node : constant Node_Access := Src_Bucket;
645 Dst_Index : constant Hash_Type :=
646 Index (Dst_Buckets.all, Src_Node);
648 Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
651 Src_Bucket := Next (Src_Node);
653 Set_Next (Src_Node, Dst_Bucket);
655 Dst_Bucket := Src_Node;
658 pragma Assert (L > 0);
663 -- If there's an error computing a hash value during a
664 -- rehash, then AI-302 says the nodes "become lost." The
665 -- issue is whether to actually deallocate these lost nodes,
666 -- since they might be designated by extant cursors. Here
667 -- we decide to deallocate the nodes, since it's better to
668 -- solve real problems (storage consumption) rather than
669 -- imaginary ones (the user might, or might not, dereference
670 -- a cursor designating a node that has been deallocated),
671 -- and because we have a way to vet a dangling cursor
672 -- reference anyway, and hence can actually detect the
675 for Dst_Index in Dst_Buckets'Range loop
677 B : Node_Access renames Dst_Buckets (Dst_Index);
688 Free_Buckets (Dst_Buckets);
689 raise Program_Error with
690 "hash function raised exception during rehash";
693 Src_Index := Src_Index + 1;
696 HT.Buckets := Dst_Buckets;
699 Free_Buckets (Src_Buckets);
701 end Reserve_Capacity;
703 end Ada.Containers.Hash_Tables.Generic_Operations;