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