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