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