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