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-2006, 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
41 new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);
47 procedure Adjust (HT : in out Hash_Table_Type) is
48 Src_Buckets : constant Buckets_Access := HT.Buckets;
49 N : constant Count_Type := HT.Length;
50 Src_Node : Node_Access;
51 Dst_Prev : Node_Access;
61 -- Technically it isn't necessary to allocate the exact same length
62 -- buckets array, because our only requirement is that following
63 -- assignment the source and target containers compare equal (that is,
64 -- operator "=" returns True). We can satisfy this requirement with any
65 -- hash table length, but we decide here to match the length of the
66 -- source table. This has the benefit that when iterating, elements of
67 -- the target are delivered in the exact same order as for the source.
69 HT.Buckets := new Buckets_Type (Src_Buckets'Range);
71 for Src_Index in Src_Buckets'Range loop
72 Src_Node := Src_Buckets (Src_Index);
74 if Src_Node /= null then
76 Dst_Node : constant Node_Access := Copy_Node (Src_Node);
80 pragma Assert (Index (HT, Dst_Node) = Src_Index);
83 HT.Buckets (Src_Index) := Dst_Node;
84 HT.Length := HT.Length + 1;
89 Src_Node := Next (Src_Node);
90 while Src_Node /= null loop
92 Dst_Node : constant Node_Access := Copy_Node (Src_Node);
96 pragma Assert (Index (HT, Dst_Node) = Src_Index);
99 Set_Next (Node => Dst_Prev, Next => Dst_Node);
100 HT.Length := HT.Length + 1;
102 Dst_Prev := Dst_Node;
105 Src_Node := Next (Src_Node);
110 pragma Assert (HT.Length = N);
117 function Capacity (HT : Hash_Table_Type) return Count_Type is
119 if HT.Buckets = null then
123 return HT.Buckets'Length;
130 procedure Clear (HT : in out Hash_Table_Type) is
131 Index : Hash_Type := 0;
139 while HT.Length > 0 loop
140 while HT.Buckets (Index) = null loop
145 Bucket : Node_Access renames HT.Buckets (Index);
149 Bucket := Next (Bucket);
150 HT.Length := HT.Length - 1;
152 exit when Bucket = null;
158 ---------------------------
159 -- Delete_Node_Sans_Free --
160 ---------------------------
162 procedure Delete_Node_Sans_Free
163 (HT : in out Hash_Table_Type;
166 pragma Assert (X /= null);
173 if HT.Length = 0 then
177 Indx := Index (HT, X);
178 Prev := HT.Buckets (Indx);
185 HT.Buckets (Indx) := Next (Prev);
186 HT.Length := HT.Length - 1;
190 if HT.Length = 1 then
202 Set_Next (Node => Prev, Next => Next (Curr));
203 HT.Length := HT.Length - 1;
209 end Delete_Node_Sans_Free;
215 procedure Finalize (HT : in out Hash_Table_Type) is
225 function First (HT : Hash_Table_Type) return Node_Access is
229 if HT.Length = 0 then
233 Indx := HT.Buckets'First;
235 if HT.Buckets (Indx) /= null then
236 return HT.Buckets (Indx);
243 ---------------------
244 -- Free_Hash_Table --
245 ---------------------
247 procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
251 if Buckets = null then
255 for J in Buckets'Range loop
256 while Buckets (J) /= null loop
258 Buckets (J) := Next (Node);
270 function Generic_Equal
271 (L, R : Hash_Table_Type) return Boolean is
274 L_Node : Node_Access;
279 if L'Address = R'Address then
283 if L.Length /= R.Length then
294 L_Node := L.Buckets (L_Index);
295 exit when L_Node /= null;
296 L_Index := L_Index + 1;
302 if not Find (HT => R, Key => L_Node) then
308 L_Node := Next (L_Node);
310 if L_Node = null then
316 L_Index := L_Index + 1;
317 L_Node := L.Buckets (L_Index);
318 exit when L_Node /= null;
324 -----------------------
325 -- Generic_Iteration --
326 -----------------------
328 procedure Generic_Iteration (HT : Hash_Table_Type) is
332 if HT.Length = 0 then
336 for Indx in HT.Buckets'Range loop
337 Node := HT.Buckets (Indx);
338 while Node /= null loop
343 end Generic_Iteration;
349 procedure Generic_Read
350 (Stream : access Root_Stream_Type'Class;
351 HT : out Hash_Table_Type)
359 Count_Type'Base'Read (Stream, N);
370 or else HT.Buckets'Length < N
373 NN := Prime_Numbers.To_Prime (N);
374 HT.Buckets := new Buckets_Type (0 .. NN - 1);
379 Node : constant Node_Access := New_Node (Stream);
380 Indx : constant Hash_Type := Index (HT, Node);
381 B : Node_Access renames HT.Buckets (Indx);
383 Set_Next (Node => Node, Next => B);
387 HT.Length := HT.Length + 1;
395 procedure Generic_Write
396 (Stream : access Root_Stream_Type'Class;
397 HT : Hash_Table_Type)
399 procedure Write (Node : Node_Access);
400 pragma Inline (Write);
402 procedure Write is new Generic_Iteration (Write);
408 procedure Write (Node : Node_Access) is
410 Write (Stream, Node);
414 Count_Type'Base'Write (Stream, HT.Length);
423 (Buckets : Buckets_Type;
424 Node : Node_Access) return Hash_Type is
426 return Hash_Node (Node) mod Buckets'Length;
430 (Hash_Table : Hash_Table_Type;
431 Node : Node_Access) return Hash_Type is
433 return Index (Hash_Table.Buckets.all, Node);
440 procedure Move (Target, Source : in out Hash_Table_Type) is
442 if Target'Address = Source'Address then
446 if Source.Busy > 0 then
453 Buckets : constant Buckets_Access := Target.Buckets;
455 Target.Buckets := Source.Buckets;
456 Source.Buckets := Buckets;
459 Target.Length := Source.Length;
468 (HT : Hash_Table_Type;
469 Node : Node_Access) return Node_Access
471 Result : Node_Access := Next (Node);
474 if Result /= null then
478 for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop
479 Result := HT.Buckets (Indx);
481 if Result /= null then
489 ----------------------
490 -- Reserve_Capacity --
491 ----------------------
493 procedure Reserve_Capacity
494 (HT : in out Hash_Table_Type;
500 if HT.Buckets = null then
502 NN := Prime_Numbers.To_Prime (N);
503 HT.Buckets := new Buckets_Type (0 .. NN - 1);
509 if HT.Length = 0 then
515 if N = HT.Buckets'Length then
519 NN := Prime_Numbers.To_Prime (N);
521 if NN = HT.Buckets'Length then
526 X : Buckets_Access := HT.Buckets;
528 HT.Buckets := new Buckets_Type (0 .. NN - 1);
535 if N = HT.Buckets'Length then
539 if N < HT.Buckets'Length then
540 if HT.Length >= HT.Buckets'Length then
544 NN := Prime_Numbers.To_Prime (HT.Length);
546 if NN >= HT.Buckets'Length then
551 NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
553 if NN = HT.Buckets'Length then -- can't expand any more
563 Dst_Buckets : Buckets_Access := new Buckets_Type (0 .. NN - 1);
564 Src_Buckets : Buckets_Access := HT.Buckets;
566 L : Count_Type renames HT.Length;
567 LL : constant Count_Type := L;
569 Src_Index : Hash_Type := Src_Buckets'First;
574 Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
577 while Src_Bucket /= null loop
579 Src_Node : constant Node_Access := Src_Bucket;
581 Dst_Index : constant Hash_Type :=
582 Index (Dst_Buckets.all, Src_Node);
584 Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
587 Src_Bucket := Next (Src_Node);
589 Set_Next (Src_Node, Dst_Bucket);
591 Dst_Bucket := Src_Node;
594 pragma Assert (L > 0);
599 -- If there's an error computing a hash value during a
600 -- rehash, then AI-302 says the nodes "become lost." The
601 -- issue is whether to actually deallocate these lost nodes,
602 -- since they might be designated by extant cursors. Here
603 -- we decide to deallocate the nodes, since it's better to
604 -- solve real problems (storage consumption) rather than
605 -- imaginary ones (the user might, or might not, dereference
606 -- a cursor designating a node that has been deallocated),
607 -- and because we have a way to vet a dangling cursor
608 -- reference anyway, and hence can actually detect the
611 for Dst_Index in Dst_Buckets'Range loop
613 B : Node_Access renames Dst_Buckets (Dst_Index);
628 Src_Index := Src_Index + 1;
631 HT.Buckets := Dst_Buckets;
636 end Reserve_Capacity;
638 end Ada.Containers.Hash_Tables.Generic_Operations;