gcc/ada/a-chtgop.adb

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