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