gcc/ada/libgnat/g-dynhta.adb

   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-2024, 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
  32 with Ada.Unchecked_Deallocation;
  33
  34 package 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
1341 end GNAT.Dynamic_HTables;