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