111
|
1 ------------------------------------------------------------------------------
|
|
2 -- --
|
|
3 -- GNAT LIBRARY COMPONENTS --
|
|
4 -- --
|
|
5 -- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS --
|
|
6 -- --
|
|
7 -- B o d y --
|
|
8 -- --
|
131
|
9 -- Copyright (C) 2004-2018, Free Software Foundation, Inc. --
|
111
|
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 -- 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. --
|
|
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
|
|
304 (HT : Hash_Table_Type) return Node_Access
|
|
305 is
|
|
306 Dummy : Hash_Type;
|
|
307 begin
|
|
308 return First (HT, Dummy);
|
|
309 end First;
|
|
310
|
|
311 function First
|
|
312 (HT : Hash_Table_Type;
|
|
313 Position : out Hash_Type) return Node_Access is
|
|
314 begin
|
|
315 if HT.Length = 0 then
|
|
316 Position := Hash_Type'Last;
|
|
317 return null;
|
|
318 end if;
|
|
319
|
|
320 Position := HT.Buckets'First;
|
|
321 loop
|
|
322 if HT.Buckets (Position) /= null then
|
|
323 return HT.Buckets (Position);
|
|
324 end if;
|
|
325
|
|
326 Position := Position + 1;
|
|
327 end loop;
|
|
328 end First;
|
|
329
|
|
330 ------------------
|
|
331 -- Free_Buckets --
|
|
332 ------------------
|
|
333
|
|
334 procedure Free_Buckets (Buckets : in out Buckets_Access) is
|
|
335 procedure Free is
|
|
336 new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Allocation);
|
|
337
|
|
338 begin
|
|
339 -- Buckets must have been created by New_Buckets. Here, we convert back
|
|
340 -- to the Buckets_Allocation type, and do the free on that.
|
|
341
|
|
342 Free (Buckets_Allocation (Buckets));
|
|
343 end Free_Buckets;
|
|
344
|
|
345 ---------------------
|
|
346 -- Free_Hash_Table --
|
|
347 ---------------------
|
|
348
|
|
349 procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
|
|
350 Node : Node_Access;
|
|
351
|
|
352 begin
|
|
353 if Buckets = null then
|
|
354 return;
|
|
355 end if;
|
|
356
|
|
357 for J in Buckets'Range loop
|
|
358 while Buckets (J) /= null loop
|
|
359 Node := Buckets (J);
|
|
360 Buckets (J) := Next (Node);
|
|
361 Free (Node);
|
|
362 end loop;
|
|
363 end loop;
|
|
364
|
|
365 Free_Buckets (Buckets);
|
|
366 end Free_Hash_Table;
|
|
367
|
|
368 -------------------
|
|
369 -- Generic_Equal --
|
|
370 -------------------
|
|
371
|
|
372 function Generic_Equal
|
|
373 (L, R : Hash_Table_Type) return Boolean
|
|
374 is
|
|
375 begin
|
|
376 if L.Length /= R.Length then
|
|
377 return False;
|
|
378 end if;
|
|
379
|
|
380 if L.Length = 0 then
|
|
381 return True;
|
|
382 end if;
|
|
383
|
|
384 declare
|
|
385 -- Per AI05-0022, the container implementation is required to detect
|
|
386 -- element tampering by a generic actual subprogram.
|
|
387
|
|
388 Lock_L : With_Lock (L.TC'Unrestricted_Access);
|
|
389 Lock_R : With_Lock (R.TC'Unrestricted_Access);
|
|
390
|
|
391 L_Index : Hash_Type;
|
|
392 L_Node : Node_Access;
|
|
393
|
|
394 N : Count_Type;
|
|
395 begin
|
|
396 -- Find the first node of hash table L
|
|
397
|
|
398 L_Index := 0;
|
|
399 loop
|
|
400 L_Node := L.Buckets (L_Index);
|
|
401 exit when L_Node /= null;
|
|
402 L_Index := L_Index + 1;
|
|
403 end loop;
|
|
404
|
|
405 -- For each node of hash table L, search for an equivalent node in
|
|
406 -- hash table R.
|
|
407
|
|
408 N := L.Length;
|
|
409 loop
|
|
410 if not Find (HT => R, Key => L_Node) then
|
|
411 return False;
|
|
412 end if;
|
|
413
|
|
414 N := N - 1;
|
|
415
|
|
416 L_Node := Next (L_Node);
|
|
417
|
|
418 if L_Node = null then
|
|
419 -- We have exhausted the nodes in this bucket
|
|
420
|
|
421 if N = 0 then
|
|
422 return True;
|
|
423 end if;
|
|
424
|
|
425 -- Find the next bucket
|
|
426
|
|
427 loop
|
|
428 L_Index := L_Index + 1;
|
|
429 L_Node := L.Buckets (L_Index);
|
|
430 exit when L_Node /= null;
|
|
431 end loop;
|
|
432 end if;
|
|
433 end loop;
|
|
434 end;
|
|
435 end Generic_Equal;
|
|
436
|
|
437 -----------------------
|
|
438 -- Generic_Iteration --
|
|
439 -----------------------
|
|
440
|
|
441 procedure Generic_Iteration (HT : Hash_Table_Type) is
|
|
442 procedure Wrapper (Node : Node_Access; Dummy_Pos : Hash_Type);
|
|
443
|
|
444 -------------
|
|
445 -- Wrapper --
|
|
446 -------------
|
|
447
|
|
448 procedure Wrapper (Node : Node_Access; Dummy_Pos : Hash_Type) is
|
|
449 begin
|
|
450 Process (Node);
|
|
451 end Wrapper;
|
|
452
|
|
453 procedure Internal_With_Pos is
|
|
454 new Generic_Iteration_With_Position (Wrapper);
|
|
455
|
|
456 -- Start of processing for Generic_Iteration
|
|
457
|
|
458 begin
|
|
459 Internal_With_Pos (HT);
|
|
460 end Generic_Iteration;
|
|
461
|
|
462 -------------------------------------
|
|
463 -- Generic_Iteration_With_Position --
|
|
464 -------------------------------------
|
|
465
|
|
466 procedure Generic_Iteration_With_Position
|
|
467 (HT : Hash_Table_Type)
|
|
468 is
|
|
469 Node : Node_Access;
|
|
470
|
|
471 begin
|
|
472 if HT.Length = 0 then
|
|
473 return;
|
|
474 end if;
|
|
475
|
|
476 for Indx in HT.Buckets'Range loop
|
|
477 Node := HT.Buckets (Indx);
|
|
478 while Node /= null loop
|
|
479 Process (Node, Indx);
|
|
480 Node := Next (Node);
|
|
481 end loop;
|
|
482 end loop;
|
|
483 end Generic_Iteration_With_Position;
|
|
484
|
|
485 ------------------
|
|
486 -- Generic_Read --
|
|
487 ------------------
|
|
488
|
|
489 procedure Generic_Read
|
|
490 (Stream : not null access Root_Stream_Type'Class;
|
|
491 HT : out Hash_Table_Type)
|
|
492 is
|
|
493 N : Count_Type'Base;
|
|
494 NN : Hash_Type;
|
|
495
|
|
496 begin
|
|
497 Clear (HT);
|
|
498
|
|
499 Count_Type'Base'Read (Stream, N);
|
|
500
|
|
501 if Checks and then N < 0 then
|
|
502 raise Program_Error with "stream appears to be corrupt";
|
|
503 end if;
|
|
504
|
|
505 if N = 0 then
|
|
506 return;
|
|
507 end if;
|
|
508
|
|
509 -- The RM does not specify whether or how the capacity changes when a
|
|
510 -- hash table is streamed in. Therefore we decide here to allocate a new
|
|
511 -- buckets array only when it's necessary to preserve representation
|
|
512 -- invariants.
|
|
513
|
|
514 if HT.Buckets = null
|
|
515 or else HT.Buckets'Length < N
|
|
516 then
|
|
517 Free_Buckets (HT.Buckets);
|
|
518 NN := Prime_Numbers.To_Prime (N);
|
|
519 HT.Buckets := New_Buckets (Length => NN);
|
|
520 end if;
|
|
521
|
|
522 for J in 1 .. N loop
|
|
523 declare
|
|
524 Node : constant Node_Access := New_Node (Stream);
|
|
525 Indx : constant Hash_Type := Checked_Index (HT, Node);
|
|
526 B : Node_Access renames HT.Buckets (Indx);
|
|
527 begin
|
|
528 Set_Next (Node => Node, Next => B);
|
|
529 B := Node;
|
|
530 end;
|
|
531
|
|
532 HT.Length := HT.Length + 1;
|
|
533 end loop;
|
|
534 end Generic_Read;
|
|
535
|
|
536 -------------------
|
|
537 -- Generic_Write --
|
|
538 -------------------
|
|
539
|
|
540 procedure Generic_Write
|
|
541 (Stream : not null access Root_Stream_Type'Class;
|
|
542 HT : Hash_Table_Type)
|
|
543 is
|
|
544 procedure Write (Node : Node_Access);
|
|
545 pragma Inline (Write);
|
|
546
|
|
547 procedure Write is new Generic_Iteration (Write);
|
|
548
|
|
549 -----------
|
|
550 -- Write --
|
|
551 -----------
|
|
552
|
|
553 procedure Write (Node : Node_Access) is
|
|
554 begin
|
|
555 Write (Stream, Node);
|
|
556 end Write;
|
|
557
|
|
558 begin
|
|
559 -- See Generic_Read for an explanation of why we do not stream out the
|
|
560 -- buckets array length too.
|
|
561
|
|
562 Count_Type'Base'Write (Stream, HT.Length);
|
|
563 Write (HT);
|
|
564 end Generic_Write;
|
|
565
|
|
566 -----------
|
|
567 -- Index --
|
|
568 -----------
|
|
569
|
|
570 function Index
|
|
571 (Buckets : Buckets_Type;
|
|
572 Node : Node_Access) return Hash_Type is
|
|
573 begin
|
|
574 return Hash_Node (Node) mod Buckets'Length;
|
|
575 end Index;
|
|
576
|
|
577 function Index
|
|
578 (Hash_Table : Hash_Table_Type;
|
|
579 Node : Node_Access) return Hash_Type is
|
|
580 begin
|
|
581 return Index (Hash_Table.Buckets.all, Node);
|
|
582 end Index;
|
|
583
|
|
584 ----------
|
|
585 -- Move --
|
|
586 ----------
|
|
587
|
|
588 procedure Move (Target, Source : in out Hash_Table_Type) is
|
|
589 begin
|
|
590 if Target'Address = Source'Address then
|
|
591 return;
|
|
592 end if;
|
|
593
|
|
594 TC_Check (Source.TC);
|
|
595
|
|
596 Clear (Target);
|
|
597
|
|
598 declare
|
|
599 Buckets : constant Buckets_Access := Target.Buckets;
|
|
600 begin
|
|
601 Target.Buckets := Source.Buckets;
|
|
602 Source.Buckets := Buckets;
|
|
603 end;
|
|
604
|
|
605 Target.Length := Source.Length;
|
|
606 Source.Length := 0;
|
|
607 end Move;
|
|
608
|
|
609 -----------------
|
|
610 -- New_Buckets --
|
|
611 -----------------
|
|
612
|
|
613 function New_Buckets (Length : Hash_Type) return Buckets_Access is
|
|
614 subtype Rng is Hash_Type range 0 .. Length - 1;
|
|
615
|
|
616 begin
|
|
617 -- Allocate in Buckets_Allocation'Storage_Pool, then convert to
|
|
618 -- Buckets_Access.
|
|
619
|
|
620 return Buckets_Access (Buckets_Allocation'(new Buckets_Type (Rng)));
|
|
621 end New_Buckets;
|
|
622
|
|
623 ----------
|
|
624 -- Next --
|
|
625 ----------
|
|
626
|
|
627 function Next
|
|
628 (HT : aliased in out Hash_Table_Type;
|
|
629 Node : Node_Access;
|
|
630 Position : in out Hash_Type) return Node_Access
|
|
631 is
|
|
632 Result : Node_Access;
|
|
633 First : Hash_Type;
|
|
634
|
|
635 begin
|
|
636 -- First, check if the node has other nodes chained to it
|
|
637 Result := Next (Node);
|
|
638
|
|
639 if Result /= null then
|
|
640 return Result;
|
|
641 end if;
|
|
642
|
|
643 -- Check if we were supplied a position for Node, from which we
|
|
644 -- can start iteration on the buckets.
|
|
645
|
|
646 if Position /= Hash_Type'Last then
|
|
647 First := Position + 1;
|
|
648 else
|
|
649 First := Checked_Index (HT, Node) + 1;
|
|
650 end if;
|
|
651
|
|
652 for Indx in First .. HT.Buckets'Last loop
|
|
653 Result := HT.Buckets (Indx);
|
|
654
|
|
655 if Result /= null then
|
|
656 Position := Indx;
|
|
657 return Result;
|
|
658 end if;
|
|
659 end loop;
|
|
660
|
|
661 return null;
|
|
662 end Next;
|
|
663
|
|
664 function Next
|
|
665 (HT : aliased in out Hash_Table_Type;
|
|
666 Node : Node_Access) return Node_Access
|
|
667 is
|
|
668 Pos : Hash_Type := Hash_Type'Last;
|
|
669 begin
|
|
670 return Next (HT, Node, Pos);
|
|
671 end Next;
|
|
672
|
|
673 ----------------------
|
|
674 -- Reserve_Capacity --
|
|
675 ----------------------
|
|
676
|
|
677 procedure Reserve_Capacity
|
|
678 (HT : in out Hash_Table_Type;
|
|
679 N : Count_Type)
|
|
680 is
|
|
681 NN : Hash_Type;
|
|
682
|
|
683 begin
|
|
684 if HT.Buckets = null then
|
|
685 if N > 0 then
|
|
686 NN := Prime_Numbers.To_Prime (N);
|
|
687 HT.Buckets := New_Buckets (Length => NN);
|
|
688 end if;
|
|
689
|
|
690 return;
|
|
691 end if;
|
|
692
|
|
693 if HT.Length = 0 then
|
|
694
|
|
695 -- This is the easy case. There are no nodes, so no rehashing is
|
|
696 -- necessary. All we need to do is allocate a new buckets array
|
|
697 -- having a length implied by the specified capacity. (We say
|
|
698 -- "implied by" because bucket arrays are always allocated with a
|
|
699 -- length that corresponds to a prime number.)
|
|
700
|
|
701 if N = 0 then
|
|
702 Free_Buckets (HT.Buckets);
|
|
703 return;
|
|
704 end if;
|
|
705
|
|
706 if N = HT.Buckets'Length then
|
|
707 return;
|
|
708 end if;
|
|
709
|
|
710 NN := Prime_Numbers.To_Prime (N);
|
|
711
|
|
712 if NN = HT.Buckets'Length then
|
|
713 return;
|
|
714 end if;
|
|
715
|
|
716 declare
|
|
717 X : Buckets_Access := HT.Buckets;
|
|
718 pragma Warnings (Off, X);
|
|
719 begin
|
|
720 HT.Buckets := New_Buckets (Length => NN);
|
|
721 Free_Buckets (X);
|
|
722 end;
|
|
723
|
|
724 return;
|
|
725 end if;
|
|
726
|
|
727 if N = HT.Buckets'Length then
|
|
728 return;
|
|
729 end if;
|
|
730
|
|
731 if N < HT.Buckets'Length then
|
|
732
|
|
733 -- This is a request to contract the buckets array. The amount of
|
|
734 -- contraction is bounded in order to preserve the invariant that the
|
|
735 -- buckets array length is never smaller than the number of elements
|
|
736 -- (the load factor is 1).
|
|
737
|
|
738 if HT.Length >= HT.Buckets'Length then
|
|
739 return;
|
|
740 end if;
|
|
741
|
|
742 NN := Prime_Numbers.To_Prime (HT.Length);
|
|
743
|
|
744 if NN >= HT.Buckets'Length then
|
|
745 return;
|
|
746 end if;
|
|
747
|
|
748 else
|
|
749 NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
|
|
750
|
|
751 if NN = HT.Buckets'Length then -- can't expand any more
|
|
752 return;
|
|
753 end if;
|
|
754 end if;
|
|
755
|
|
756 TC_Check (HT.TC);
|
|
757
|
|
758 Rehash : declare
|
|
759 Dst_Buckets : Buckets_Access := New_Buckets (Length => NN);
|
|
760 Src_Buckets : Buckets_Access := HT.Buckets;
|
|
761 pragma Warnings (Off, Src_Buckets);
|
|
762
|
|
763 L : Count_Type renames HT.Length;
|
|
764 LL : constant Count_Type := L;
|
|
765
|
|
766 Src_Index : Hash_Type := Src_Buckets'First;
|
|
767
|
|
768 begin
|
|
769 while L > 0 loop
|
|
770 declare
|
|
771 Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
|
|
772
|
|
773 begin
|
|
774 while Src_Bucket /= null loop
|
|
775 declare
|
|
776 Src_Node : constant Node_Access := Src_Bucket;
|
|
777
|
|
778 Dst_Index : constant Hash_Type :=
|
|
779 Checked_Index (HT, Dst_Buckets.all, Src_Node);
|
|
780
|
|
781 Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
|
|
782
|
|
783 begin
|
|
784 Src_Bucket := Next (Src_Node);
|
|
785
|
|
786 Set_Next (Src_Node, Dst_Bucket);
|
|
787
|
|
788 Dst_Bucket := Src_Node;
|
|
789 end;
|
|
790
|
|
791 pragma Assert (L > 0);
|
|
792 L := L - 1;
|
|
793 end loop;
|
|
794
|
|
795 exception
|
|
796 when others =>
|
|
797
|
|
798 -- If there's an error computing a hash value during a
|
|
799 -- rehash, then AI-302 says the nodes "become lost." The
|
|
800 -- issue is whether to actually deallocate these lost nodes,
|
|
801 -- since they might be designated by extant cursors. Here
|
|
802 -- we decide to deallocate the nodes, since it's better to
|
|
803 -- solve real problems (storage consumption) rather than
|
|
804 -- imaginary ones (the user might, or might not, dereference
|
|
805 -- a cursor designating a node that has been deallocated),
|
|
806 -- and because we have a way to vet a dangling cursor
|
|
807 -- reference anyway, and hence can actually detect the
|
|
808 -- problem.
|
|
809
|
|
810 for Dst_Index in Dst_Buckets'Range loop
|
|
811 declare
|
|
812 B : Node_Access renames Dst_Buckets (Dst_Index);
|
|
813 X : Node_Access;
|
|
814 begin
|
|
815 while B /= null loop
|
|
816 X := B;
|
|
817 B := Next (X);
|
|
818 Free (X);
|
|
819 end loop;
|
|
820 end;
|
|
821 end loop;
|
|
822
|
|
823 Free_Buckets (Dst_Buckets);
|
|
824 raise Program_Error with
|
|
825 "hash function raised exception during rehash";
|
|
826 end;
|
|
827
|
|
828 Src_Index := Src_Index + 1;
|
|
829 end loop;
|
|
830
|
|
831 HT.Buckets := Dst_Buckets;
|
|
832 HT.Length := LL;
|
|
833
|
|
834 Free_Buckets (Src_Buckets);
|
|
835 end Rehash;
|
|
836 end Reserve_Capacity;
|
|
837
|
|
838 end Ada.Containers.Hash_Tables.Generic_Operations;
|