File : a-chtgop.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
29
30 with Ada.Containers.Prime_Numbers;
31 with Ada.Unchecked_Deallocation;
32
33 with System; use type System.Address;
34
35 package body Ada.Containers.Hash_Tables.Generic_Operations is
36
37 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
38 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
39 -- See comment in Ada.Containers.Helpers
40
41 type Buckets_Allocation is access all Buckets_Type;
42 -- Used for allocation and deallocation (see New_Buckets and Free_Buckets).
43 -- This is necessary because Buckets_Access has an empty storage pool.
44
45 ------------
46 -- Adjust --
47 ------------
48
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;
54
55 begin
56 -- If the counts are nonzero, execution is technically erroneous, but
57 -- it seems friendly to allow things like concurrent "=" on shared
58 -- constants.
59
60 Zero_Counts (HT.TC);
61
62 HT.Buckets := null;
63 HT.Length := 0;
64
65 if N = 0 then
66 return;
67 end if;
68
69 -- Technically it isn't necessary to allocate the exact same length
70 -- buckets array, because our only requirement is that following
71 -- assignment the source and target containers compare equal (that is,
72 -- operator "=" returns True). We can satisfy this requirement with any
73 -- hash table length, but we decide here to match the length of the
74 -- source table. This has the benefit that when iterating, elements of
75 -- the target are delivered in the exact same order as for the source.
76
77 HT.Buckets := New_Buckets (Length => Src_Buckets'Length);
78
79 for Src_Index in Src_Buckets'Range loop
80 Src_Node := Src_Buckets (Src_Index);
81
82 if Src_Node /= null then
83 declare
84 Dst_Node : constant Node_Access := Copy_Node (Src_Node);
85
86 -- See note above
87
88 pragma Assert (Checked_Index (HT, Dst_Node) = Src_Index);
89
90 begin
91 HT.Buckets (Src_Index) := Dst_Node;
92 HT.Length := HT.Length + 1;
93
94 Dst_Prev := Dst_Node;
95 end;
96
97 Src_Node := Next (Src_Node);
98 while Src_Node /= null loop
99 declare
100 Dst_Node : constant Node_Access := Copy_Node (Src_Node);
101
102 -- See note above
103
104 pragma Assert (Checked_Index (HT, Dst_Node) = Src_Index);
105
106 begin
107 Set_Next (Node => Dst_Prev, Next => Dst_Node);
108 HT.Length := HT.Length + 1;
109
110 Dst_Prev := Dst_Node;
111 end;
112
113 Src_Node := Next (Src_Node);
114 end loop;
115 end if;
116 end loop;
117
118 pragma Assert (HT.Length = N);
119 end Adjust;
120
121 --------------
122 -- Capacity --
123 --------------
124
125 function Capacity (HT : Hash_Table_Type) return Count_Type is
126 begin
127 if HT.Buckets = null then
128 return 0;
129 end if;
130
131 return HT.Buckets'Length;
132 end Capacity;
133
134 -------------------
135 -- Checked_Index --
136 -------------------
137
138 function Checked_Index
139 (Hash_Table : aliased in out Hash_Table_Type;
140 Buckets : Buckets_Type;
141 Node : Node_Access) return Hash_Type
142 is
143 Lock : With_Lock (Hash_Table.TC'Unrestricted_Access);
144 begin
145 return Index (Buckets, Node);
146 end Checked_Index;
147
148 function Checked_Index
149 (Hash_Table : aliased in out Hash_Table_Type;
150 Node : Node_Access) return Hash_Type
151 is
152 begin
153 return Checked_Index (Hash_Table, Hash_Table.Buckets.all, Node);
154 end Checked_Index;
155
156 -----------
157 -- Clear --
158 -----------
159
160 procedure Clear (HT : in out Hash_Table_Type) is
161 Index : Hash_Type := 0;
162 Node : Node_Access;
163
164 begin
165 TC_Check (HT.TC);
166
167 while HT.Length > 0 loop
168 while HT.Buckets (Index) = null loop
169 Index := Index + 1;
170 end loop;
171
172 declare
173 Bucket : Node_Access renames HT.Buckets (Index);
174 begin
175 loop
176 Node := Bucket;
177 Bucket := Next (Bucket);
178 HT.Length := HT.Length - 1;
179 Free (Node);
180 exit when Bucket = null;
181 end loop;
182 end;
183 end loop;
184 end Clear;
185
186 --------------------------
187 -- Delete_Node_At_Index --
188 --------------------------
189
190 procedure Delete_Node_At_Index
191 (HT : in out Hash_Table_Type;
192 Indx : Hash_Type;
193 X : in out Node_Access)
194 is
195 Prev : Node_Access;
196 Curr : Node_Access;
197
198 begin
199 Prev := HT.Buckets (Indx);
200
201 if Prev = X then
202 HT.Buckets (Indx) := Next (Prev);
203 HT.Length := HT.Length - 1;
204 Free (X);
205 return;
206 end if;
207
208 if Checks and then HT.Length = 1 then
209 raise Program_Error with
210 "attempt to delete node not in its proper hash bucket";
211 end if;
212
213 loop
214 Curr := Next (Prev);
215
216 if Checks and then Curr = null then
217 raise Program_Error with
218 "attempt to delete node not in its proper hash bucket";
219 end if;
220
221 if Curr = X then
222 Set_Next (Node => Prev, Next => Next (Curr));
223 HT.Length := HT.Length - 1;
224 Free (X);
225 return;
226 end if;
227
228 Prev := Curr;
229 end loop;
230 end Delete_Node_At_Index;
231
232 ---------------------------
233 -- Delete_Node_Sans_Free --
234 ---------------------------
235
236 procedure Delete_Node_Sans_Free
237 (HT : in out Hash_Table_Type;
238 X : Node_Access)
239 is
240 pragma Assert (X /= null);
241
242 Indx : Hash_Type;
243 Prev : Node_Access;
244 Curr : Node_Access;
245
246 begin
247 if Checks and then HT.Length = 0 then
248 raise Program_Error with
249 "attempt to delete node from empty hashed container";
250 end if;
251
252 Indx := Checked_Index (HT, X);
253 Prev := HT.Buckets (Indx);
254
255 if Checks and then Prev = null then
256 raise Program_Error with
257 "attempt to delete node from empty hash bucket";
258 end if;
259
260 if Prev = X then
261 HT.Buckets (Indx) := Next (Prev);
262 HT.Length := HT.Length - 1;
263 return;
264 end if;
265
266 if Checks and then HT.Length = 1 then
267 raise Program_Error with
268 "attempt to delete node not in its proper hash bucket";
269 end if;
270
271 loop
272 Curr := Next (Prev);
273
274 if Checks and then Curr = null then
275 raise Program_Error with
276 "attempt to delete node not in its proper hash bucket";
277 end if;
278
279 if Curr = X then
280 Set_Next (Node => Prev, Next => Next (Curr));
281 HT.Length := HT.Length - 1;
282 return;
283 end if;
284
285 Prev := Curr;
286 end loop;
287 end Delete_Node_Sans_Free;
288
289 --------------
290 -- Finalize --
291 --------------
292
293 procedure Finalize (HT : in out Hash_Table_Type) is
294 begin
295 Clear (HT);
296 Free_Buckets (HT.Buckets);
297 end Finalize;
298
299 -----------
300 -- First --
301 -----------
302
303 function First (HT : Hash_Table_Type) return Node_Access is
304 Indx : Hash_Type;
305
306 begin
307 if HT.Length = 0 then
308 return null;
309 end if;
310
311 Indx := HT.Buckets'First;
312 loop
313 if HT.Buckets (Indx) /= null then
314 return HT.Buckets (Indx);
315 end if;
316
317 Indx := Indx + 1;
318 end loop;
319 end First;
320
321 ------------------
322 -- Free_Buckets --
323 ------------------
324
325 procedure Free_Buckets (Buckets : in out Buckets_Access) is
326 procedure Free is
327 new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Allocation);
328
329 begin
330 -- Buckets must have been created by New_Buckets. Here, we convert back
331 -- to the Buckets_Allocation type, and do the free on that.
332
333 Free (Buckets_Allocation (Buckets));
334 end Free_Buckets;
335
336 ---------------------
337 -- Free_Hash_Table --
338 ---------------------
339
340 procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
341 Node : Node_Access;
342
343 begin
344 if Buckets = null then
345 return;
346 end if;
347
348 for J in Buckets'Range loop
349 while Buckets (J) /= null loop
350 Node := Buckets (J);
351 Buckets (J) := Next (Node);
352 Free (Node);
353 end loop;
354 end loop;
355
356 Free_Buckets (Buckets);
357 end Free_Hash_Table;
358
359 -------------------
360 -- Generic_Equal --
361 -------------------
362
363 function Generic_Equal
364 (L, R : Hash_Table_Type) return Boolean
365 is
366 begin
367 if L.Length /= R.Length then
368 return False;
369 end if;
370
371 if L.Length = 0 then
372 return True;
373 end if;
374
375 declare
376 -- Per AI05-0022, the container implementation is required to detect
377 -- element tampering by a generic actual subprogram.
378
379 Lock_L : With_Lock (L.TC'Unrestricted_Access);
380 Lock_R : With_Lock (R.TC'Unrestricted_Access);
381
382 L_Index : Hash_Type;
383 L_Node : Node_Access;
384
385 N : Count_Type;
386 begin
387 -- Find the first node of hash table L
388
389 L_Index := 0;
390 loop
391 L_Node := L.Buckets (L_Index);
392 exit when L_Node /= null;
393 L_Index := L_Index + 1;
394 end loop;
395
396 -- For each node of hash table L, search for an equivalent node in
397 -- hash table R.
398
399 N := L.Length;
400 loop
401 if not Find (HT => R, Key => L_Node) then
402 return False;
403 end if;
404
405 N := N - 1;
406
407 L_Node := Next (L_Node);
408
409 if L_Node = null then
410 -- We have exhausted the nodes in this bucket
411
412 if N = 0 then
413 return True;
414 end if;
415
416 -- Find the next bucket
417
418 loop
419 L_Index := L_Index + 1;
420 L_Node := L.Buckets (L_Index);
421 exit when L_Node /= null;
422 end loop;
423 end if;
424 end loop;
425 end;
426 end Generic_Equal;
427
428 -----------------------
429 -- Generic_Iteration --
430 -----------------------
431
432 procedure Generic_Iteration (HT : Hash_Table_Type) is
433 Node : Node_Access;
434
435 begin
436 if HT.Length = 0 then
437 return;
438 end if;
439
440 for Indx in HT.Buckets'Range loop
441 Node := HT.Buckets (Indx);
442 while Node /= null loop
443 Process (Node);
444 Node := Next (Node);
445 end loop;
446 end loop;
447 end Generic_Iteration;
448
449 ------------------
450 -- Generic_Read --
451 ------------------
452
453 procedure Generic_Read
454 (Stream : not null access Root_Stream_Type'Class;
455 HT : out Hash_Table_Type)
456 is
457 N : Count_Type'Base;
458 NN : Hash_Type;
459
460 begin
461 Clear (HT);
462
463 Count_Type'Base'Read (Stream, N);
464
465 if Checks and then N < 0 then
466 raise Program_Error with "stream appears to be corrupt";
467 end if;
468
469 if N = 0 then
470 return;
471 end if;
472
473 -- The RM does not specify whether or how the capacity changes when a
474 -- hash table is streamed in. Therefore we decide here to allocate a new
475 -- buckets array only when it's necessary to preserve representation
476 -- invariants.
477
478 if HT.Buckets = null
479 or else HT.Buckets'Length < N
480 then
481 Free_Buckets (HT.Buckets);
482 NN := Prime_Numbers.To_Prime (N);
483 HT.Buckets := New_Buckets (Length => NN);
484 end if;
485
486 for J in 1 .. N loop
487 declare
488 Node : constant Node_Access := New_Node (Stream);
489 Indx : constant Hash_Type := Checked_Index (HT, Node);
490 B : Node_Access renames HT.Buckets (Indx);
491 begin
492 Set_Next (Node => Node, Next => B);
493 B := Node;
494 end;
495
496 HT.Length := HT.Length + 1;
497 end loop;
498 end Generic_Read;
499
500 -------------------
501 -- Generic_Write --
502 -------------------
503
504 procedure Generic_Write
505 (Stream : not null access Root_Stream_Type'Class;
506 HT : Hash_Table_Type)
507 is
508 procedure Write (Node : Node_Access);
509 pragma Inline (Write);
510
511 procedure Write is new Generic_Iteration (Write);
512
513 -----------
514 -- Write --
515 -----------
516
517 procedure Write (Node : Node_Access) is
518 begin
519 Write (Stream, Node);
520 end Write;
521
522 begin
523 -- See Generic_Read for an explanation of why we do not stream out the
524 -- buckets array length too.
525
526 Count_Type'Base'Write (Stream, HT.Length);
527 Write (HT);
528 end Generic_Write;
529
530 -----------
531 -- Index --
532 -----------
533
534 function Index
535 (Buckets : Buckets_Type;
536 Node : Node_Access) return Hash_Type is
537 begin
538 return Hash_Node (Node) mod Buckets'Length;
539 end Index;
540
541 function Index
542 (Hash_Table : Hash_Table_Type;
543 Node : Node_Access) return Hash_Type is
544 begin
545 return Index (Hash_Table.Buckets.all, Node);
546 end Index;
547
548 ----------
549 -- Move --
550 ----------
551
552 procedure Move (Target, Source : in out Hash_Table_Type) is
553 begin
554 if Target'Address = Source'Address then
555 return;
556 end if;
557
558 TC_Check (Source.TC);
559
560 Clear (Target);
561
562 declare
563 Buckets : constant Buckets_Access := Target.Buckets;
564 begin
565 Target.Buckets := Source.Buckets;
566 Source.Buckets := Buckets;
567 end;
568
569 Target.Length := Source.Length;
570 Source.Length := 0;
571 end Move;
572
573 -----------------
574 -- New_Buckets --
575 -----------------
576
577 function New_Buckets (Length : Hash_Type) return Buckets_Access is
578 subtype Rng is Hash_Type range 0 .. Length - 1;
579
580 begin
581 -- Allocate in Buckets_Allocation'Storage_Pool, then convert to
582 -- Buckets_Access.
583
584 return Buckets_Access (Buckets_Allocation'(new Buckets_Type (Rng)));
585 end New_Buckets;
586
587 ----------
588 -- Next --
589 ----------
590
591 function Next
592 (HT : aliased in out Hash_Table_Type;
593 Node : Node_Access) return Node_Access
594 is
595 Result : Node_Access;
596 First : Hash_Type;
597
598 begin
599 Result := Next (Node);
600
601 if Result /= null then
602 return Result;
603 end if;
604
605 First := Checked_Index (HT, Node) + 1;
606 for Indx in First .. HT.Buckets'Last loop
607 Result := HT.Buckets (Indx);
608
609 if Result /= null then
610 return Result;
611 end if;
612 end loop;
613
614 return null;
615 end Next;
616
617 ----------------------
618 -- Reserve_Capacity --
619 ----------------------
620
621 procedure Reserve_Capacity
622 (HT : in out Hash_Table_Type;
623 N : Count_Type)
624 is
625 NN : Hash_Type;
626
627 begin
628 if HT.Buckets = null then
629 if N > 0 then
630 NN := Prime_Numbers.To_Prime (N);
631 HT.Buckets := New_Buckets (Length => NN);
632 end if;
633
634 return;
635 end if;
636
637 if HT.Length = 0 then
638
639 -- This is the easy case. There are no nodes, so no rehashing is
640 -- necessary. All we need to do is allocate a new buckets array
641 -- having a length implied by the specified capacity. (We say
642 -- "implied by" because bucket arrays are always allocated with a
643 -- length that corresponds to a prime number.)
644
645 if N = 0 then
646 Free_Buckets (HT.Buckets);
647 return;
648 end if;
649
650 if N = HT.Buckets'Length then
651 return;
652 end if;
653
654 NN := Prime_Numbers.To_Prime (N);
655
656 if NN = HT.Buckets'Length then
657 return;
658 end if;
659
660 declare
661 X : Buckets_Access := HT.Buckets;
662 pragma Warnings (Off, X);
663 begin
664 HT.Buckets := New_Buckets (Length => NN);
665 Free_Buckets (X);
666 end;
667
668 return;
669 end if;
670
671 if N = HT.Buckets'Length then
672 return;
673 end if;
674
675 if N < HT.Buckets'Length then
676
677 -- This is a request to contract the buckets array. The amount of
678 -- contraction is bounded in order to preserve the invariant that the
679 -- buckets array length is never smaller than the number of elements
680 -- (the load factor is 1).
681
682 if HT.Length >= HT.Buckets'Length then
683 return;
684 end if;
685
686 NN := Prime_Numbers.To_Prime (HT.Length);
687
688 if NN >= HT.Buckets'Length then
689 return;
690 end if;
691
692 else
693 NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
694
695 if NN = HT.Buckets'Length then -- can't expand any more
696 return;
697 end if;
698 end if;
699
700 TC_Check (HT.TC);
701
702 Rehash : declare
703 Dst_Buckets : Buckets_Access := New_Buckets (Length => NN);
704 Src_Buckets : Buckets_Access := HT.Buckets;
705 pragma Warnings (Off, Src_Buckets);
706
707 L : Count_Type renames HT.Length;
708 LL : constant Count_Type := L;
709
710 Src_Index : Hash_Type := Src_Buckets'First;
711
712 begin
713 while L > 0 loop
714 declare
715 Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
716
717 begin
718 while Src_Bucket /= null loop
719 declare
720 Src_Node : constant Node_Access := Src_Bucket;
721
722 Dst_Index : constant Hash_Type :=
723 Checked_Index (HT, Dst_Buckets.all, Src_Node);
724
725 Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
726
727 begin
728 Src_Bucket := Next (Src_Node);
729
730 Set_Next (Src_Node, Dst_Bucket);
731
732 Dst_Bucket := Src_Node;
733 end;
734
735 pragma Assert (L > 0);
736 L := L - 1;
737 end loop;
738
739 exception
740 when others =>
741
742 -- If there's an error computing a hash value during a
743 -- rehash, then AI-302 says the nodes "become lost." The
744 -- issue is whether to actually deallocate these lost nodes,
745 -- since they might be designated by extant cursors. Here
746 -- we decide to deallocate the nodes, since it's better to
747 -- solve real problems (storage consumption) rather than
748 -- imaginary ones (the user might, or might not, dereference
749 -- a cursor designating a node that has been deallocated),
750 -- and because we have a way to vet a dangling cursor
751 -- reference anyway, and hence can actually detect the
752 -- problem.
753
754 for Dst_Index in Dst_Buckets'Range loop
755 declare
756 B : Node_Access renames Dst_Buckets (Dst_Index);
757 X : Node_Access;
758 begin
759 while B /= null loop
760 X := B;
761 B := Next (X);
762 Free (X);
763 end loop;
764 end;
765 end loop;
766
767 Free_Buckets (Dst_Buckets);
768 raise Program_Error with
769 "hash function raised exception during rehash";
770 end;
771
772 Src_Index := Src_Index + 1;
773 end loop;
774
775 HT.Buckets := Dst_Buckets;
776 HT.Length := LL;
777
778 Free_Buckets (Src_Buckets);
779 end Rehash;
780 end Reserve_Capacity;
781
782 end Ada.Containers.Hash_Tables.Generic_Operations;