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