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