1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- G N A T . D Y N A M I C _ H T A B L E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2002-2020, AdaCore -- 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-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with Ada.Unchecked_Deallocation; 33 34package body GNAT.Dynamic_HTables is 35 36 ------------------- 37 -- Hash_Two_Keys -- 38 ------------------- 39 40 function Hash_Two_Keys 41 (Left : Bucket_Range_Type; 42 Right : Bucket_Range_Type) return Bucket_Range_Type 43 is 44 Half : constant := 2 ** (Bucket_Range_Type'Size / 2); 45 Mask : constant := Half - 1; 46 47 begin 48 -- The hash is obtained in the following manner: 49 -- 50 -- 1) The low bits of Left are obtained, then shifted over to the high 51 -- bits position. 52 -- 53 -- 2) The low bits of Right are obtained 54 -- 55 -- The results from 1) and 2) are or-ed to produce a value within the 56 -- range of Bucket_Range_Type. 57 58 return 59 ((Left and Mask) * Half) 60 or 61 (Right and Mask); 62 end Hash_Two_Keys; 63 64 ------------------- 65 -- Static_HTable -- 66 ------------------- 67 68 package body Static_HTable is 69 function Get_Non_Null (T : Instance) return Elmt_Ptr; 70 -- Returns Null_Ptr if Iterator_Started is False or if the Table is 71 -- empty. Returns Iterator_Ptr if non null, or the next non null element 72 -- in table if any. 73 74 --------- 75 -- Get -- 76 --------- 77 78 function Get (T : Instance; K : Key) return Elmt_Ptr is 79 Elmt : Elmt_Ptr; 80 81 begin 82 if T = null then 83 return Null_Ptr; 84 end if; 85 86 Elmt := T.Table (Hash (K)); 87 88 loop 89 if Elmt = Null_Ptr then 90 return Null_Ptr; 91 92 elsif Equal (Get_Key (Elmt), K) then 93 return Elmt; 94 95 else 96 Elmt := Next (Elmt); 97 end if; 98 end loop; 99 end Get; 100 101 --------------- 102 -- Get_First -- 103 --------------- 104 105 function Get_First (T : Instance) return Elmt_Ptr is 106 begin 107 if T = null then 108 return Null_Ptr; 109 end if; 110 111 T.Iterator_Started := True; 112 T.Iterator_Index := T.Table'First; 113 T.Iterator_Ptr := T.Table (T.Iterator_Index); 114 return Get_Non_Null (T); 115 end Get_First; 116 117 -------------- 118 -- Get_Next -- 119 -------------- 120 121 function Get_Next (T : Instance) return Elmt_Ptr is 122 begin 123 if T = null or else not T.Iterator_Started then 124 return Null_Ptr; 125 end if; 126 127 T.Iterator_Ptr := Next (T.Iterator_Ptr); 128 return Get_Non_Null (T); 129 end Get_Next; 130 131 ------------------ 132 -- Get_Non_Null -- 133 ------------------ 134 135 function Get_Non_Null (T : Instance) return Elmt_Ptr is 136 begin 137 if T = null then 138 return Null_Ptr; 139 end if; 140 141 while T.Iterator_Ptr = Null_Ptr loop 142 if T.Iterator_Index = T.Table'Last then 143 T.Iterator_Started := False; 144 return Null_Ptr; 145 end if; 146 147 T.Iterator_Index := T.Iterator_Index + 1; 148 T.Iterator_Ptr := T.Table (T.Iterator_Index); 149 end loop; 150 151 return T.Iterator_Ptr; 152 end Get_Non_Null; 153 154 ------------ 155 -- Remove -- 156 ------------ 157 158 procedure Remove (T : Instance; K : Key) is 159 Index : constant Header_Num := Hash (K); 160 Elmt : Elmt_Ptr; 161 Next_Elmt : Elmt_Ptr; 162 163 begin 164 if T = null then 165 return; 166 end if; 167 168 Elmt := T.Table (Index); 169 170 if Elmt = Null_Ptr then 171 return; 172 173 elsif Equal (Get_Key (Elmt), K) then 174 T.Table (Index) := Next (Elmt); 175 176 else 177 loop 178 Next_Elmt := Next (Elmt); 179 180 if Next_Elmt = Null_Ptr then 181 return; 182 183 elsif Equal (Get_Key (Next_Elmt), K) then 184 Set_Next (Elmt, Next (Next_Elmt)); 185 return; 186 187 else 188 Elmt := Next_Elmt; 189 end if; 190 end loop; 191 end if; 192 end Remove; 193 194 ----------- 195 -- Reset -- 196 ----------- 197 198 procedure Reset (T : in out Instance) is 199 procedure Free is 200 new Ada.Unchecked_Deallocation (Instance_Data, Instance); 201 202 begin 203 if T = null then 204 return; 205 end if; 206 207 for J in T.Table'Range loop 208 T.Table (J) := Null_Ptr; 209 end loop; 210 211 Free (T); 212 end Reset; 213 214 --------- 215 -- Set -- 216 --------- 217 218 procedure Set (T : in out Instance; E : Elmt_Ptr) is 219 Index : Header_Num; 220 221 begin 222 if T = null then 223 T := new Instance_Data; 224 end if; 225 226 Index := Hash (Get_Key (E)); 227 Set_Next (E, T.Table (Index)); 228 T.Table (Index) := E; 229 end Set; 230 231 end Static_HTable; 232 233 ------------------- 234 -- Simple_HTable -- 235 ------------------- 236 237 package body Simple_HTable is 238 procedure Free is new 239 Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr); 240 241 --------- 242 -- Get -- 243 --------- 244 245 function Get (T : Instance; K : Key) return Element is 246 Tmp : Elmt_Ptr; 247 248 begin 249 if T = Nil then 250 return No_Element; 251 end if; 252 253 Tmp := Tab.Get (Tab.Instance (T), K); 254 255 if Tmp = null then 256 return No_Element; 257 else 258 return Tmp.E; 259 end if; 260 end Get; 261 262 --------------- 263 -- Get_First -- 264 --------------- 265 266 function Get_First (T : Instance) return Element is 267 Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T)); 268 269 begin 270 if Tmp = null then 271 return No_Element; 272 else 273 return Tmp.E; 274 end if; 275 end Get_First; 276 277 ------------------- 278 -- Get_First_Key -- 279 ------------------- 280 281 function Get_First_Key (T : Instance) return Key_Option is 282 Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T)); 283 begin 284 if Tmp = null then 285 return Key_Option'(Present => False); 286 else 287 return Key_Option'(Present => True, K => Tmp.all.K); 288 end if; 289 end Get_First_Key; 290 291 ------------- 292 -- Get_Key -- 293 ------------- 294 295 function Get_Key (E : Elmt_Ptr) return Key is 296 begin 297 return E.K; 298 end Get_Key; 299 300 -------------- 301 -- Get_Next -- 302 -------------- 303 304 function Get_Next (T : Instance) return Element is 305 Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T)); 306 begin 307 if Tmp = null then 308 return No_Element; 309 else 310 return Tmp.E; 311 end if; 312 end Get_Next; 313 314 ------------------ 315 -- Get_Next_Key -- 316 ------------------ 317 318 function Get_Next_Key (T : Instance) return Key_Option is 319 Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T)); 320 begin 321 if Tmp = null then 322 return Key_Option'(Present => False); 323 else 324 return Key_Option'(Present => True, K => Tmp.all.K); 325 end if; 326 end Get_Next_Key; 327 328 ---------- 329 -- Next -- 330 ---------- 331 332 function Next (E : Elmt_Ptr) return Elmt_Ptr is 333 begin 334 return E.Next; 335 end Next; 336 337 ------------ 338 -- Remove -- 339 ------------ 340 341 procedure Remove (T : Instance; K : Key) is 342 Tmp : Elmt_Ptr; 343 344 begin 345 Tmp := Tab.Get (Tab.Instance (T), K); 346 347 if Tmp /= null then 348 Tab.Remove (Tab.Instance (T), K); 349 Free (Tmp); 350 end if; 351 end Remove; 352 353 ----------- 354 -- Reset -- 355 ----------- 356 357 procedure Reset (T : in out Instance) is 358 E1, E2 : Elmt_Ptr; 359 360 begin 361 E1 := Tab.Get_First (Tab.Instance (T)); 362 while E1 /= null loop 363 E2 := Tab.Get_Next (Tab.Instance (T)); 364 Free (E1); 365 E1 := E2; 366 end loop; 367 368 Tab.Reset (Tab.Instance (T)); 369 end Reset; 370 371 --------- 372 -- Set -- 373 --------- 374 375 procedure Set (T : in out Instance; K : Key; E : Element) is 376 Tmp : constant Elmt_Ptr := Tab.Get (Tab.Instance (T), K); 377 begin 378 if Tmp = null then 379 Tab.Set (Tab.Instance (T), new Element_Wrapper'(K, E, null)); 380 else 381 Tmp.E := E; 382 end if; 383 end Set; 384 385 -------------- 386 -- Set_Next -- 387 -------------- 388 389 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is 390 begin 391 E.Next := Next; 392 end Set_Next; 393 end Simple_HTable; 394 395 ------------------------- 396 -- Dynamic_Hash_Tables -- 397 ------------------------- 398 399 package body Dynamic_Hash_Tables is 400 Minimum_Size : constant Bucket_Range_Type := 8; 401 -- Minimum size of the buckets 402 403 Safe_Compression_Size : constant Bucket_Range_Type := 404 Minimum_Size * Compression_Factor; 405 -- Maximum safe size for hash table compression. Beyond this size, a 406 -- compression will violate the minimum size constraint on the buckets. 407 408 Safe_Expansion_Size : constant Bucket_Range_Type := 409 Bucket_Range_Type'Last / Expansion_Factor; 410 -- Maximum safe size for hash table expansion. Beyond this size, an 411 -- expansion will overflow the buckets. 412 413 procedure Delete_Node 414 (T : Dynamic_Hash_Table; 415 Nod : Node_Ptr); 416 pragma Inline (Delete_Node); 417 -- Detach and delete node Nod from table T 418 419 procedure Destroy_Buckets (Bkts : Bucket_Table_Ptr); 420 pragma Inline (Destroy_Buckets); 421 -- Destroy all nodes within buckets Bkts 422 423 procedure Detach (Nod : Node_Ptr); 424 pragma Inline (Detach); 425 -- Detach node Nod from the bucket it resides in 426 427 procedure Ensure_Circular (Head : Node_Ptr); 428 pragma Inline (Ensure_Circular); 429 -- Ensure that dummy head Head is circular with respect to itself 430 431 procedure Ensure_Created (T : Dynamic_Hash_Table); 432 pragma Inline (Ensure_Created); 433 -- Verify that hash table T is created. Raise Not_Created if this is not 434 -- the case. 435 436 procedure Ensure_Unlocked (T : Dynamic_Hash_Table); 437 pragma Inline (Ensure_Unlocked); 438 -- Verify that hash table T is unlocked. Raise Iterated if this is not 439 -- the case. 440 441 function Find_Bucket 442 (Bkts : Bucket_Table_Ptr; 443 Key : Key_Type) return Node_Ptr; 444 pragma Inline (Find_Bucket); 445 -- Find the bucket among buckets Bkts which corresponds to key Key, and 446 -- return its dummy head. 447 448 function Find_Node (Head : Node_Ptr; Key : Key_Type) return Node_Ptr; 449 pragma Inline (Find_Node); 450 -- Traverse a bucket indicated by dummy head Head to determine whether 451 -- there exists a node with key Key. If such a node exists, return it, 452 -- otherwise return null. 453 454 procedure First_Valid_Node 455 (T : Dynamic_Hash_Table; 456 Low_Bkt : Bucket_Range_Type; 457 High_Bkt : Bucket_Range_Type; 458 Idx : out Bucket_Range_Type; 459 Nod : out Node_Ptr); 460 pragma Inline (First_Valid_Node); 461 -- Find the first valid node in the buckets of hash table T constrained 462 -- by the range Low_Bkt .. High_Bkt. If such a node exists, return its 463 -- bucket index in Idx and reference in Nod. If no such node exists, 464 -- Idx is set to 0 and Nod to null. 465 466 procedure Free is 467 new Ada.Unchecked_Deallocation (Bucket_Table, Bucket_Table_Ptr); 468 469 procedure Free is 470 new Ada.Unchecked_Deallocation 471 (Dynamic_Hash_Table_Attributes, Dynamic_Hash_Table); 472 473 procedure Free is 474 new Ada.Unchecked_Deallocation (Node, Node_Ptr); 475 476 function Is_Valid (Iter : Iterator) return Boolean; 477 pragma Inline (Is_Valid); 478 -- Determine whether iterator Iter refers to a valid key-value pair 479 480 function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean; 481 pragma Inline (Is_Valid); 482 -- Determine whether node Nod is non-null and does not refer to dummy 483 -- head Head, thus making it valid. 484 485 function Load_Factor (T : Dynamic_Hash_Table) return Threshold_Type; 486 pragma Inline (Load_Factor); 487 -- Calculate the load factor of hash table T 488 489 procedure Lock (T : Dynamic_Hash_Table); 490 pragma Inline (Lock); 491 -- Lock all mutation functionality of hash table T 492 493 procedure Mutate_And_Rehash 494 (T : Dynamic_Hash_Table; 495 Size : Bucket_Range_Type); 496 pragma Inline (Mutate_And_Rehash); 497 -- Replace the buckets of hash table T with a new set of buckets of size 498 -- Size. Rehash all key-value pairs from the old to the new buckets. 499 500 procedure Prepend (Nod : Node_Ptr; Head : Node_Ptr); 501 pragma Inline (Prepend); 502 -- Insert node Nod immediately after dummy head Head 503 504 function Present (Bkts : Bucket_Table_Ptr) return Boolean; 505 pragma Inline (Present); 506 -- Determine whether buckets Bkts exist 507 508 function Present (Nod : Node_Ptr) return Boolean; 509 pragma Inline (Present); 510 -- Determine whether node Nod exists 511 512 procedure Unlock (T : Dynamic_Hash_Table); 513 pragma Inline (Unlock); 514 -- Unlock all mutation functionality of hash table T 515 516 -------------- 517 -- Contains -- 518 -------------- 519 520 function Contains 521 (T : Dynamic_Hash_Table; 522 Key : Key_Type) return Boolean 523 is 524 Head : Node_Ptr; 525 Nod : Node_Ptr; 526 527 begin 528 Ensure_Created (T); 529 530 -- Obtain the dummy head of the bucket which should house the 531 -- key-value pair. 532 533 Head := Find_Bucket (T.Buckets, Key); 534 535 -- Try to find a node in the bucket which matches the key 536 537 Nod := Find_Node (Head, Key); 538 539 return Is_Valid (Nod, Head); 540 end Contains; 541 542 ------------ 543 -- Create -- 544 ------------ 545 546 function Create (Initial_Size : Positive) return Dynamic_Hash_Table is 547 Size : constant Bucket_Range_Type := 548 Bucket_Range_Type'Max 549 (Bucket_Range_Type (Initial_Size), Minimum_Size); 550 -- Ensure that the buckets meet a minimum size 551 552 T : constant Dynamic_Hash_Table := new Dynamic_Hash_Table_Attributes; 553 554 begin 555 T.Buckets := new Bucket_Table (0 .. Size - 1); 556 T.Initial_Size := Size; 557 558 return T; 559 end Create; 560 561 ------------ 562 -- Delete -- 563 ------------ 564 565 procedure Delete 566 (T : Dynamic_Hash_Table; 567 Key : Key_Type) 568 is 569 Head : Node_Ptr; 570 Nod : Node_Ptr; 571 572 begin 573 Ensure_Created (T); 574 Ensure_Unlocked (T); 575 576 -- Obtain the dummy head of the bucket which should house the 577 -- key-value pair. 578 579 Head := Find_Bucket (T.Buckets, Key); 580 581 -- Try to find a node in the bucket which matches the key 582 583 Nod := Find_Node (Head, Key); 584 585 -- If such a node exists, remove it from the bucket and deallocate it 586 587 if Is_Valid (Nod, Head) then 588 Delete_Node (T, Nod); 589 end if; 590 end Delete; 591 592 ----------------- 593 -- Delete_Node -- 594 ----------------- 595 596 procedure Delete_Node 597 (T : Dynamic_Hash_Table; 598 Nod : Node_Ptr) 599 is 600 procedure Compress; 601 pragma Inline (Compress); 602 -- Determine whether hash table T requires compression, and if so, 603 -- half its size. 604 605 -------------- 606 -- Compress -- 607 -------------- 608 609 procedure Compress is 610 pragma Assert (Present (T)); 611 pragma Assert (Present (T.Buckets)); 612 613 Old_Size : constant Bucket_Range_Type := T.Buckets'Length; 614 615 begin 616 -- The ratio of pairs to buckets is under the desited threshold. 617 -- Compress the hash table only when there is still room to do so. 618 619 if Load_Factor (T) < Compression_Threshold 620 and then Old_Size >= Safe_Compression_Size 621 then 622 Mutate_And_Rehash (T, Old_Size / Compression_Factor); 623 end if; 624 end Compress; 625 626 -- Local variables 627 628 Ref : Node_Ptr := Nod; 629 630 -- Start of processing for Delete_Node 631 632 begin 633 pragma Assert (Present (Ref)); 634 pragma Assert (Present (T)); 635 636 Detach (Ref); 637 Free (Ref); 638 639 -- The number of key-value pairs is updated when the hash table 640 -- contains a valid node which represents the pair. 641 642 T.Pairs := T.Pairs - 1; 643 644 -- Compress the hash table if the load factor drops below the value 645 -- of Compression_Threshold. 646 647 Compress; 648 end Delete_Node; 649 650 ------------- 651 -- Destroy -- 652 ------------- 653 654 procedure Destroy (T : in out Dynamic_Hash_Table) is 655 begin 656 Ensure_Created (T); 657 Ensure_Unlocked (T); 658 659 -- Destroy all nodes in all buckets 660 661 Destroy_Buckets (T.Buckets); 662 Free (T.Buckets); 663 Free (T); 664 end Destroy; 665 666 --------------------- 667 -- Destroy_Buckets -- 668 --------------------- 669 670 procedure Destroy_Buckets (Bkts : Bucket_Table_Ptr) is 671 procedure Destroy_Bucket (Head : Node_Ptr); 672 pragma Inline (Destroy_Bucket); 673 -- Destroy all nodes in a bucket with dummy head Head 674 675 -------------------- 676 -- Destroy_Bucket -- 677 -------------------- 678 679 procedure Destroy_Bucket (Head : Node_Ptr) is 680 Nod : Node_Ptr; 681 682 begin 683 -- Destroy all valid nodes which follow the dummy head 684 685 while Is_Valid (Head.Next, Head) loop 686 Nod := Head.Next; 687 688 -- Invoke the value destructor before deallocating the node 689 690 Destroy_Value (Nod.Value); 691 692 Detach (Nod); 693 Free (Nod); 694 end loop; 695 end Destroy_Bucket; 696 697 -- Start of processing for Destroy_Buckets 698 699 begin 700 pragma Assert (Present (Bkts)); 701 702 for Scan_Idx in Bkts'Range loop 703 Destroy_Bucket (Bkts (Scan_Idx)'Access); 704 end loop; 705 end Destroy_Buckets; 706 707 ------------ 708 -- Detach -- 709 ------------ 710 711 procedure Detach (Nod : Node_Ptr) is 712 pragma Assert (Present (Nod)); 713 714 Next : constant Node_Ptr := Nod.Next; 715 Prev : constant Node_Ptr := Nod.Prev; 716 717 begin 718 pragma Assert (Present (Next)); 719 pragma Assert (Present (Prev)); 720 721 Prev.Next := Next; -- Prev ---> Next 722 Next.Prev := Prev; -- Prev <--> Next 723 724 Nod.Next := null; 725 Nod.Prev := null; 726 end Detach; 727 728 --------------------- 729 -- Ensure_Circular -- 730 --------------------- 731 732 procedure Ensure_Circular (Head : Node_Ptr) is 733 pragma Assert (Present (Head)); 734 735 begin 736 if not Present (Head.Next) and then not Present (Head.Prev) then 737 Head.Next := Head; 738 Head.Prev := Head; 739 end if; 740 end Ensure_Circular; 741 742 -------------------- 743 -- Ensure_Created -- 744 -------------------- 745 746 procedure Ensure_Created (T : Dynamic_Hash_Table) is 747 begin 748 if not Present (T) then 749 raise Not_Created; 750 end if; 751 end Ensure_Created; 752 753 --------------------- 754 -- Ensure_Unlocked -- 755 --------------------- 756 757 procedure Ensure_Unlocked (T : Dynamic_Hash_Table) is 758 begin 759 pragma Assert (Present (T)); 760 761 -- The hash table has at least one outstanding iterator 762 763 if T.Iterators > 0 then 764 raise Iterated; 765 end if; 766 end Ensure_Unlocked; 767 768 ----------------- 769 -- Find_Bucket -- 770 ----------------- 771 772 function Find_Bucket 773 (Bkts : Bucket_Table_Ptr; 774 Key : Key_Type) return Node_Ptr 775 is 776 pragma Assert (Present (Bkts)); 777 778 Idx : constant Bucket_Range_Type := Hash (Key) mod Bkts'Length; 779 780 begin 781 return Bkts (Idx)'Access; 782 end Find_Bucket; 783 784 --------------- 785 -- Find_Node -- 786 --------------- 787 788 function Find_Node (Head : Node_Ptr; Key : Key_Type) return Node_Ptr is 789 pragma Assert (Present (Head)); 790 791 Nod : Node_Ptr; 792 793 begin 794 -- Traverse the nodes of the bucket, looking for a key-value pair 795 -- with the same key. 796 797 Nod := Head.Next; 798 while Is_Valid (Nod, Head) loop 799 if Nod.Key = Key then 800 return Nod; 801 end if; 802 803 Nod := Nod.Next; 804 end loop; 805 806 return null; 807 end Find_Node; 808 809 ---------------------- 810 -- First_Valid_Node -- 811 ---------------------- 812 813 procedure First_Valid_Node 814 (T : Dynamic_Hash_Table; 815 Low_Bkt : Bucket_Range_Type; 816 High_Bkt : Bucket_Range_Type; 817 Idx : out Bucket_Range_Type; 818 Nod : out Node_Ptr) 819 is 820 Head : Node_Ptr; 821 822 begin 823 pragma Assert (Present (T)); 824 pragma Assert (Present (T.Buckets)); 825 826 -- Assume that no valid node exists 827 828 Idx := 0; 829 Nod := null; 830 831 -- Examine the buckets of the hash table within the requested range, 832 -- looking for the first valid node. 833 834 for Scan_Idx in Low_Bkt .. High_Bkt loop 835 Head := T.Buckets (Scan_Idx)'Access; 836 837 -- The bucket contains at least one valid node, return the first 838 -- such node. 839 840 if Is_Valid (Head.Next, Head) then 841 Idx := Scan_Idx; 842 Nod := Head.Next; 843 return; 844 end if; 845 end loop; 846 end First_Valid_Node; 847 848 --------- 849 -- Get -- 850 --------- 851 852 function Get 853 (T : Dynamic_Hash_Table; 854 Key : Key_Type) return Value_Type 855 is 856 Head : Node_Ptr; 857 Nod : Node_Ptr; 858 859 begin 860 Ensure_Created (T); 861 862 -- Obtain the dummy head of the bucket which should house the 863 -- key-value pair. 864 865 Head := Find_Bucket (T.Buckets, Key); 866 867 -- Try to find a node in the bucket which matches the key 868 869 Nod := Find_Node (Head, Key); 870 871 -- If such a node exists, return the value of the key-value pair 872 873 if Is_Valid (Nod, Head) then 874 return Nod.Value; 875 end if; 876 877 return No_Value; 878 end Get; 879 880 -------------- 881 -- Has_Next -- 882 -------------- 883 884 function Has_Next (Iter : Iterator) return Boolean is 885 Is_OK : constant Boolean := Is_Valid (Iter); 886 T : constant Dynamic_Hash_Table := Iter.Table; 887 888 begin 889 pragma Assert (Present (T)); 890 891 -- The iterator is no longer valid which indicates that it has been 892 -- exhausted. Unlock all mutation functionality of the hash table 893 -- because the iterator cannot be advanced any further. 894 895 if not Is_OK then 896 Unlock (T); 897 end if; 898 899 return Is_OK; 900 end Has_Next; 901 902 -------------- 903 -- Is_Empty -- 904 -------------- 905 906 function Is_Empty (T : Dynamic_Hash_Table) return Boolean is 907 begin 908 Ensure_Created (T); 909 910 return T.Pairs = 0; 911 end Is_Empty; 912 913 -------------- 914 -- Is_Valid -- 915 -------------- 916 917 function Is_Valid (Iter : Iterator) return Boolean is 918 begin 919 -- The invariant of Iterate and Next ensures that the iterator always 920 -- refers to a valid node if there exists one. 921 922 return Present (Iter.Curr_Nod); 923 end Is_Valid; 924 925 -------------- 926 -- Is_Valid -- 927 -------------- 928 929 function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean is 930 begin 931 -- A node is valid if it is non-null, and does not refer to the dummy 932 -- head of some bucket. 933 934 return Present (Nod) and then Nod /= Head; 935 end Is_Valid; 936 937 ------------- 938 -- Iterate -- 939 ------------- 940 941 function Iterate (T : Dynamic_Hash_Table) return Iterator is 942 Iter : Iterator; 943 944 begin 945 Ensure_Created (T); 946 pragma Assert (Present (T.Buckets)); 947 948 -- Initialize the iterator to reference the first valid node in 949 -- the full range of hash table buckets. If no such node exists, 950 -- the iterator is left in a state which does not allow it to 951 -- advance. 952 953 First_Valid_Node 954 (T => T, 955 Low_Bkt => T.Buckets'First, 956 High_Bkt => T.Buckets'Last, 957 Idx => Iter.Curr_Idx, 958 Nod => Iter.Curr_Nod); 959 960 -- Associate the iterator with the hash table to allow for future 961 -- mutation functionality unlocking. 962 963 Iter.Table := T; 964 965 -- Lock all mutation functionality of the hash table while it is 966 -- being iterated on. 967 968 Lock (T); 969 970 return Iter; 971 end Iterate; 972 973 ----------------- 974 -- Load_Factor -- 975 ----------------- 976 977 function Load_Factor (T : Dynamic_Hash_Table) return Threshold_Type is 978 pragma Assert (Present (T)); 979 pragma Assert (Present (T.Buckets)); 980 981 begin 982 -- The load factor is the ratio of key-value pairs to buckets 983 984 return Threshold_Type (T.Pairs) / Threshold_Type (T.Buckets'Length); 985 end Load_Factor; 986 987 ---------- 988 -- Lock -- 989 ---------- 990 991 procedure Lock (T : Dynamic_Hash_Table) is 992 begin 993 -- The hash table may be locked multiple times if multiple iterators 994 -- are operating over it. 995 996 T.Iterators := T.Iterators + 1; 997 end Lock; 998 999 ----------------------- 1000 -- Mutate_And_Rehash -- 1001 ----------------------- 1002 1003 procedure Mutate_And_Rehash 1004 (T : Dynamic_Hash_Table; 1005 Size : Bucket_Range_Type) 1006 is 1007 procedure Rehash (From : Bucket_Table_Ptr; To : Bucket_Table_Ptr); 1008 pragma Inline (Rehash); 1009 -- Remove all nodes from buckets From and rehash them into buckets To 1010 1011 procedure Rehash_Bucket (Head : Node_Ptr; To : Bucket_Table_Ptr); 1012 pragma Inline (Rehash_Bucket); 1013 -- Detach all nodes starting from dummy head Head and rehash them 1014 -- into To. 1015 1016 procedure Rehash_Node (Nod : Node_Ptr; To : Bucket_Table_Ptr); 1017 pragma Inline (Rehash_Node); 1018 -- Rehash node Nod into To 1019 1020 ------------ 1021 -- Rehash -- 1022 ------------ 1023 1024 procedure Rehash (From : Bucket_Table_Ptr; To : Bucket_Table_Ptr) is 1025 begin 1026 pragma Assert (Present (From)); 1027 pragma Assert (Present (To)); 1028 1029 for Scan_Idx in From'Range loop 1030 Rehash_Bucket (From (Scan_Idx)'Access, To); 1031 end loop; 1032 end Rehash; 1033 1034 ------------------- 1035 -- Rehash_Bucket -- 1036 ------------------- 1037 1038 procedure Rehash_Bucket (Head : Node_Ptr; To : Bucket_Table_Ptr) is 1039 pragma Assert (Present (Head)); 1040 1041 Nod : Node_Ptr; 1042 1043 begin 1044 -- Detach all nodes which follow the dummy head 1045 1046 while Is_Valid (Head.Next, Head) loop 1047 Nod := Head.Next; 1048 1049 Detach (Nod); 1050 Rehash_Node (Nod, To); 1051 end loop; 1052 end Rehash_Bucket; 1053 1054 ----------------- 1055 -- Rehash_Node -- 1056 ----------------- 1057 1058 procedure Rehash_Node (Nod : Node_Ptr; To : Bucket_Table_Ptr) is 1059 pragma Assert (Present (Nod)); 1060 1061 Head : Node_Ptr; 1062 1063 begin 1064 -- Obtain the dummy head of the bucket which should house the 1065 -- key-value pair. 1066 1067 Head := Find_Bucket (To, Nod.Key); 1068 1069 -- Ensure that the dummy head of an empty bucket is circular with 1070 -- respect to itself. 1071 1072 Ensure_Circular (Head); 1073 1074 -- Prepend the node to the bucket 1075 1076 Prepend (Nod, Head); 1077 end Rehash_Node; 1078 1079 -- Local declarations 1080 1081 Old_Bkts : Bucket_Table_Ptr; 1082 1083 -- Start of processing for Mutate_And_Rehash 1084 1085 begin 1086 pragma Assert (Present (T)); 1087 1088 Old_Bkts := T.Buckets; 1089 T.Buckets := new Bucket_Table (0 .. Size - 1); 1090 1091 -- Transfer and rehash all key-value pairs from the old buckets to 1092 -- the new buckets. 1093 1094 Rehash (From => Old_Bkts, To => T.Buckets); 1095 Free (Old_Bkts); 1096 end Mutate_And_Rehash; 1097 1098 ---------- 1099 -- Next -- 1100 ---------- 1101 1102 procedure Next (Iter : in out Iterator; Key : out Key_Type) is 1103 Is_OK : constant Boolean := Is_Valid (Iter); 1104 Saved : constant Node_Ptr := Iter.Curr_Nod; 1105 T : constant Dynamic_Hash_Table := Iter.Table; 1106 Head : Node_Ptr; 1107 1108 begin 1109 pragma Assert (Present (T)); 1110 pragma Assert (Present (T.Buckets)); 1111 1112 -- The iterator is no longer valid which indicates that it has been 1113 -- exhausted. Unlock all mutation functionality of the hash table as 1114 -- the iterator cannot be advanced any further. 1115 1116 if not Is_OK then 1117 Unlock (T); 1118 raise Iterator_Exhausted; 1119 end if; 1120 1121 -- Advance to the next node along the same bucket 1122 1123 Iter.Curr_Nod := Iter.Curr_Nod.Next; 1124 Head := T.Buckets (Iter.Curr_Idx)'Access; 1125 1126 -- If the new node is no longer valid, then this indicates that the 1127 -- current bucket has been exhausted. Advance to the next valid node 1128 -- within the remaining range of buckets. If no such node exists, the 1129 -- iterator is left in a state which does not allow it to advance. 1130 1131 if not Is_Valid (Iter.Curr_Nod, Head) then 1132 First_Valid_Node 1133 (T => T, 1134 Low_Bkt => Iter.Curr_Idx + 1, 1135 High_Bkt => T.Buckets'Last, 1136 Idx => Iter.Curr_Idx, 1137 Nod => Iter.Curr_Nod); 1138 end if; 1139 1140 Key := Saved.Key; 1141 end Next; 1142 1143 ------------- 1144 -- Prepend -- 1145 ------------- 1146 1147 procedure Prepend (Nod : Node_Ptr; Head : Node_Ptr) is 1148 pragma Assert (Present (Nod)); 1149 pragma Assert (Present (Head)); 1150 1151 Next : constant Node_Ptr := Head.Next; 1152 1153 begin 1154 Head.Next := Nod; 1155 Next.Prev := Nod; 1156 1157 Nod.Next := Next; 1158 Nod.Prev := Head; 1159 end Prepend; 1160 1161 ------------- 1162 -- Present -- 1163 ------------- 1164 1165 function Present (Bkts : Bucket_Table_Ptr) return Boolean is 1166 begin 1167 return Bkts /= null; 1168 end Present; 1169 1170 ------------- 1171 -- Present -- 1172 ------------- 1173 1174 function Present (Nod : Node_Ptr) return Boolean is 1175 begin 1176 return Nod /= null; 1177 end Present; 1178 1179 ------------- 1180 -- Present -- 1181 ------------- 1182 1183 function Present (T : Dynamic_Hash_Table) return Boolean is 1184 begin 1185 return T /= Nil; 1186 end Present; 1187 1188 --------- 1189 -- Put -- 1190 --------- 1191 1192 procedure Put 1193 (T : Dynamic_Hash_Table; 1194 Key : Key_Type; 1195 Value : Value_Type) 1196 is 1197 procedure Expand; 1198 pragma Inline (Expand); 1199 -- Determine whether hash table T requires expansion, and if so, 1200 -- double its size. 1201 1202 procedure Prepend_Or_Replace (Head : Node_Ptr); 1203 pragma Inline (Prepend_Or_Replace); 1204 -- Update the value of a node within a bucket with dummy head Head 1205 -- whose key is Key to Value. If there is no such node, prepend a new 1206 -- key-value pair to the bucket. 1207 1208 ------------ 1209 -- Expand -- 1210 ------------ 1211 1212 procedure Expand is 1213 pragma Assert (Present (T)); 1214 pragma Assert (Present (T.Buckets)); 1215 1216 Old_Size : constant Bucket_Range_Type := T.Buckets'Length; 1217 1218 begin 1219 -- The ratio of pairs to buckets is over the desited threshold. 1220 -- Expand the hash table only when there is still room to do so. 1221 1222 if Load_Factor (T) > Expansion_Threshold 1223 and then Old_Size <= Safe_Expansion_Size 1224 then 1225 Mutate_And_Rehash (T, Old_Size * Expansion_Factor); 1226 end if; 1227 end Expand; 1228 1229 ------------------------ 1230 -- Prepend_Or_Replace -- 1231 ------------------------ 1232 1233 procedure Prepend_Or_Replace (Head : Node_Ptr) is 1234 pragma Assert (Present (Head)); 1235 1236 Nod : Node_Ptr; 1237 1238 begin 1239 -- If the bucket containst at least one valid node, then there is 1240 -- a chance that a node with the same key as Key exists. If this 1241 -- is the case, the value of that node must be updated. 1242 1243 Nod := Head.Next; 1244 while Is_Valid (Nod, Head) loop 1245 if Nod.Key = Key then 1246 Nod.Value := Value; 1247 return; 1248 end if; 1249 1250 Nod := Nod.Next; 1251 end loop; 1252 1253 -- At this point the bucket is either empty, or none of the nodes 1254 -- match key Key. Prepend a new key-value pair. 1255 1256 Nod := new Node'(Key, Value, null, null); 1257 1258 Prepend (Nod, Head); 1259 1260 -- The number of key-value pairs must be updated for a prepend, 1261 -- never for a replace. 1262 1263 T.Pairs := T.Pairs + 1; 1264 end Prepend_Or_Replace; 1265 1266 -- Local variables 1267 1268 Head : Node_Ptr; 1269 1270 -- Start of processing for Put 1271 1272 begin 1273 Ensure_Created (T); 1274 Ensure_Unlocked (T); 1275 1276 -- Obtain the dummy head of the bucket which should house the 1277 -- key-value pair. 1278 1279 Head := Find_Bucket (T.Buckets, Key); 1280 1281 -- Ensure that the dummy head of an empty bucket is circular with 1282 -- respect to itself. 1283 1284 Ensure_Circular (Head); 1285 1286 -- In case the bucket already contains a node with the same key, 1287 -- replace its value, otherwise prepend a new key-value pair. 1288 1289 Prepend_Or_Replace (Head); 1290 1291 -- Expand the hash table if the ratio of pairs to buckets goes over 1292 -- Expansion_Threshold. 1293 1294 Expand; 1295 end Put; 1296 1297 ----------- 1298 -- Reset -- 1299 ----------- 1300 1301 procedure Reset (T : Dynamic_Hash_Table) is 1302 begin 1303 Ensure_Created (T); 1304 Ensure_Unlocked (T); 1305 1306 -- Destroy all nodes in all buckets 1307 1308 Destroy_Buckets (T.Buckets); 1309 Free (T.Buckets); 1310 1311 -- Recreate the buckets using the original size from creation time 1312 1313 T.Buckets := new Bucket_Table (0 .. T.Initial_Size - 1); 1314 T.Pairs := 0; 1315 end Reset; 1316 1317 ---------- 1318 -- Size -- 1319 ---------- 1320 1321 function Size (T : Dynamic_Hash_Table) return Natural is 1322 begin 1323 Ensure_Created (T); 1324 1325 return T.Pairs; 1326 end Size; 1327 1328 ------------ 1329 -- Unlock -- 1330 ------------ 1331 1332 procedure Unlock (T : Dynamic_Hash_Table) is 1333 begin 1334 -- The hash table may be locked multiple times if multiple iterators 1335 -- are operating over it. 1336 1337 T.Iterators := T.Iterators - 1; 1338 end Unlock; 1339 end Dynamic_Hash_Tables; 1340 1341end GNAT.Dynamic_HTables; 1342