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-2018, 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-- 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 30with Ada.Containers.Prime_Numbers; 31with Ada.Unchecked_Deallocation; 32 33with System; use type System.Address; 34 35package 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 838end Ada.Containers.Hash_Tables.Generic_Operations; 839