gcc/ada/libgnat/a-chtgop.adb

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