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-2008, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- This unit was originally developed by Matthew J Heaney.                  --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Containers.Prime_Numbers;
  33 with Ada.Unchecked_Deallocation;
  34
  35 with System;  use type System.Address;
  36
  37 package body Ada.Containers.Hash_Tables.Generic_Operations is
  38
  39    type Buckets_Allocation is access all Buckets_Type;
  40    --  Used for allocation and deallocation (see New_Buckets and Free_Buckets).
  41    --  This is necessary because Buckets_Access has an empty storage pool.
  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 (Length => Src_Buckets'Length);
  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_Buckets (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_Buckets --
 250    ------------------
 251
 252    procedure Free_Buckets (Buckets : in out Buckets_Access) is
 253       procedure Free is
 254         new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Allocation);
 255
 256    begin
 257       --  Buckets must have been created by New_Buckets. Here, we convert back
 258       --  to the Buckets_Allocation type, and do the free on that.
 259
 260       Free (Buckets_Allocation (Buckets));
 261    end Free_Buckets;
 262
 263    ---------------------
 264    -- Free_Hash_Table --
 265    ---------------------
 266
 267    procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
 268       Node : Node_Access;
 269
 270    begin
 271       if Buckets = null then
 272          return;
 273       end if;
 274
 275       for J in Buckets'Range loop
 276          while Buckets (J) /= null loop
 277             Node := Buckets (J);
 278             Buckets (J) := Next (Node);
 279             Free (Node);
 280          end loop;
 281       end loop;
 282
 283       Free_Buckets (Buckets);
 284    end Free_Hash_Table;
 285
 286    -------------------
 287    -- Generic_Equal --
 288    -------------------
 289
 290    function Generic_Equal
 291      (L, R : Hash_Table_Type) return Boolean
 292    is
 293       L_Index : Hash_Type;
 294       L_Node  : Node_Access;
 295
 296       N : Count_Type;
 297
 298    begin
 299       if L'Address = R'Address then
 300          return True;
 301       end if;
 302
 303       if L.Length /= R.Length then
 304          return False;
 305       end if;
 306
 307       if L.Length = 0 then
 308          return True;
 309       end if;
 310
 311       --  Find the first node of hash table L
 312
 313       L_Index := 0;
 314       loop
 315          L_Node := L.Buckets (L_Index);
 316          exit when L_Node /= null;
 317          L_Index := L_Index + 1;
 318       end loop;
 319
 320       --  For each node of hash table L, search for an equivalent node in hash
 321       --  table R.
 322
 323       N := L.Length;
 324       loop
 325          if not Find (HT => R, Key => L_Node) then
 326             return False;
 327          end if;
 328
 329          N := N - 1;
 330
 331          L_Node := Next (L_Node);
 332
 333          if L_Node = null then
 334             --  We have exhausted the nodes in this bucket
 335
 336             if N = 0 then
 337                return True;
 338             end if;
 339
 340             --  Find the next bucket
 341
 342             loop
 343                L_Index := L_Index + 1;
 344                L_Node := L.Buckets (L_Index);
 345                exit when L_Node /= null;
 346             end loop;
 347          end if;
 348       end loop;
 349    end Generic_Equal;
 350
 351    -----------------------
 352    -- Generic_Iteration --
 353    -----------------------
 354
 355    procedure Generic_Iteration (HT : Hash_Table_Type) is
 356       Node : Node_Access;
 357
 358    begin
 359       if HT.Length = 0 then
 360          return;
 361       end if;
 362
 363       for Indx in HT.Buckets'Range loop
 364          Node := HT.Buckets (Indx);
 365          while Node /= null loop
 366             Process (Node);
 367             Node := Next (Node);
 368          end loop;
 369       end loop;
 370    end Generic_Iteration;
 371
 372    ------------------
 373    -- Generic_Read --
 374    ------------------
 375
 376    procedure Generic_Read
 377      (Stream : not null access Root_Stream_Type'Class;
 378       HT     : out Hash_Table_Type)
 379    is
 380       N  : Count_Type'Base;
 381       NN : Hash_Type;
 382
 383    begin
 384       Clear (HT);
 385
 386       Count_Type'Base'Read (Stream, N);
 387
 388       if N < 0 then
 389          raise Program_Error with "stream appears to be corrupt";
 390       end if;
 391
 392       if N = 0 then
 393          return;
 394       end if;
 395
 396       --  The RM does not specify whether or how the capacity changes when a
 397       --  hash table is streamed in. Therefore we decide here to allocate a new
 398       --  buckets array only when it's necessary to preserve representation
 399       --  invariants.
 400
 401       if HT.Buckets = null
 402         or else HT.Buckets'Length < N
 403       then
 404          Free_Buckets (HT.Buckets);
 405          NN := Prime_Numbers.To_Prime (N);
 406          HT.Buckets := New_Buckets (Length => NN);
 407       end if;
 408
 409       for J in 1 .. N loop
 410          declare
 411             Node : constant Node_Access := New_Node (Stream);
 412             Indx : constant Hash_Type := Index (HT, Node);
 413             B    : Node_Access renames HT.Buckets (Indx);
 414          begin
 415             Set_Next (Node => Node, Next => B);
 416             B := Node;
 417          end;
 418
 419          HT.Length := HT.Length + 1;
 420       end loop;
 421    end Generic_Read;
 422
 423    -------------------
 424    -- Generic_Write --
 425    -------------------
 426
 427    procedure Generic_Write
 428      (Stream : not null access Root_Stream_Type'Class;
 429       HT     : Hash_Table_Type)
 430    is
 431       procedure Write (Node : Node_Access);
 432       pragma Inline (Write);
 433
 434       procedure Write is new Generic_Iteration (Write);
 435
 436       -----------
 437       -- Write --
 438       -----------
 439
 440       procedure Write (Node : Node_Access) is
 441       begin
 442          Write (Stream, Node);
 443       end Write;
 444
 445    begin
 446       --  See Generic_Read for an explanation of why we do not stream out the
 447       --  buckets array length too.
 448
 449       Count_Type'Base'Write (Stream, HT.Length);
 450       Write (HT);
 451    end Generic_Write;
 452
 453    -----------
 454    -- Index --
 455    -----------
 456
 457    function Index
 458      (Buckets : Buckets_Type;
 459       Node    : Node_Access) return Hash_Type is
 460    begin
 461       return Hash_Node (Node) mod Buckets'Length;
 462    end Index;
 463
 464    function Index
 465      (Hash_Table : Hash_Table_Type;
 466       Node       : Node_Access) return Hash_Type is
 467    begin
 468       return Index (Hash_Table.Buckets.all, Node);
 469    end Index;
 470
 471    ----------
 472    -- Move --
 473    ----------
 474
 475    procedure Move (Target, Source : in out Hash_Table_Type) is
 476    begin
 477       if Target'Address = Source'Address then
 478          return;
 479       end if;
 480
 481       if Source.Busy > 0 then
 482          raise Program_Error with
 483            "attempt to tamper with elements (container is busy)";
 484       end if;
 485
 486       Clear (Target);
 487
 488       declare
 489          Buckets : constant Buckets_Access := Target.Buckets;
 490       begin
 491          Target.Buckets := Source.Buckets;
 492          Source.Buckets := Buckets;
 493       end;
 494
 495       Target.Length := Source.Length;
 496       Source.Length := 0;
 497    end Move;
 498
 499    -----------------
 500    -- New_Buckets --
 501    -----------------
 502
 503    function New_Buckets (Length : Hash_Type) return Buckets_Access is
 504       subtype Rng is Hash_Type range 0 .. Length - 1;
 505
 506    begin
 507       --  Allocate in Buckets_Allocation'Storage_Pool, then convert to
 508       --  Buckets_Access.
 509
 510       return Buckets_Access (Buckets_Allocation'(new Buckets_Type (Rng)));
 511    end New_Buckets;
 512
 513    ----------
 514    -- Next --
 515    ----------
 516
 517    function Next
 518      (HT   : Hash_Table_Type;
 519       Node : Node_Access) return Node_Access
 520    is
 521       Result : Node_Access := Next (Node);
 522
 523    begin
 524       if Result /= null then
 525          return Result;
 526       end if;
 527
 528       for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop
 529          Result := HT.Buckets (Indx);
 530
 531          if Result /= null then
 532             return Result;
 533          end if;
 534       end loop;
 535
 536       return null;
 537    end Next;
 538
 539    ----------------------
 540    -- Reserve_Capacity --
 541    ----------------------
 542
 543    procedure Reserve_Capacity
 544      (HT : in out Hash_Table_Type;
 545       N  : Count_Type)
 546    is
 547       NN : Hash_Type;
 548
 549    begin
 550       if HT.Buckets = null then
 551          if N > 0 then
 552             NN := Prime_Numbers.To_Prime (N);
 553             HT.Buckets := New_Buckets (Length => NN);
 554          end if;
 555
 556          return;
 557       end if;
 558
 559       if HT.Length = 0 then
 560
 561          --  This is the easy case. There are no nodes, so no rehashing is
 562          --  necessary. All we need to do is allocate a new buckets array
 563          --  having a length implied by the specified capacity. (We say
 564          --  "implied by" because bucket arrays are always allocated with a
 565          --  length that corresponds to a prime number.)
 566
 567          if N = 0 then
 568             Free_Buckets (HT.Buckets);
 569             return;
 570          end if;
 571
 572          if N = HT.Buckets'Length then
 573             return;
 574          end if;
 575
 576          NN := Prime_Numbers.To_Prime (N);
 577
 578          if NN = HT.Buckets'Length then
 579             return;
 580          end if;
 581
 582          declare
 583             X : Buckets_Access := HT.Buckets;
 584             pragma Warnings (Off, X);
 585          begin
 586             HT.Buckets := New_Buckets (Length => NN);
 587             Free_Buckets (X);
 588          end;
 589
 590          return;
 591       end if;
 592
 593       if N = HT.Buckets'Length then
 594          return;
 595       end if;
 596
 597       if N < HT.Buckets'Length then
 598
 599          --  This is a request to contract the buckets array. The amount of
 600          --  contraction is bounded in order to preserve the invariant that the
 601          --  buckets array length is never smaller than the number of elements
 602          --  (the load factor is 1).
 603
 604          if HT.Length >= HT.Buckets'Length then
 605             return;
 606          end if;
 607
 608          NN := Prime_Numbers.To_Prime (HT.Length);
 609
 610          if NN >= HT.Buckets'Length then
 611             return;
 612          end if;
 613
 614       else
 615          NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
 616
 617          if NN = HT.Buckets'Length then -- can't expand any more
 618             return;
 619          end if;
 620       end if;
 621
 622       if HT.Busy > 0 then
 623          raise Program_Error with
 624            "attempt to tamper with elements (container is busy)";
 625       end if;
 626
 627       Rehash : declare
 628          Dst_Buckets : Buckets_Access := New_Buckets (Length => NN);
 629          Src_Buckets : Buckets_Access := HT.Buckets;
 630          pragma Warnings (Off, Src_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;