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-2005, 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 --  This body needs commenting ???
  34
  35 with Ada.Containers.Prime_Numbers;
  36 with Ada.Unchecked_Deallocation;
  37
  38 with System;  use type System.Address;
  39
  40 package body Ada.Containers.Hash_Tables.Generic_Operations is
  41
  42    procedure Free is
  43      new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);
  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       HT.Buckets := new Buckets_Type (Src_Buckets'Range);
  64       --  TODO: allocate minimum size req'd.  (See note below.)
  65
  66       --  NOTE: see note below about these comments.
  67       --  Probably we have to duplicate the Size (Src), too, in order
  68       --  to guarantee that
  69
  70       --    Dst := Src;
  71       --    Dst = Src is true
  72
  73       --  The only quirk is that we depend on the hash value of a dst key
  74       --  to be the same as the src key from which it was copied.
  75       --  If we relax the requirement that the hash value must be the
  76       --  same, then of course we can't guarantee that following
  77       --  assignment that Dst = Src is true ???
  78       --
  79       --  NOTE: 17 Apr 2005
  80       --  What I said above is no longer true.  The semantics of (map) equality
  81       --  changed, such that we use key in the left map to look up the
  82       --  equivalent key in the right map, and then compare the elements (using
  83       --  normal equality) of the equivalent keys.  So it doesn't matter that
  84       --  the maps have different capacities (i.e. the hash tables have
  85       --  different lengths), since we just look up the key, irrespective of
  86       --  its map's hash table length.  All the RM says we're required to do
  87       --  it arrange for the target map to "=" the source map following an
  88       --  assignment (that is, following an Adjust), so it doesn't matter
  89       --  what the capacity of the target map is.  What I'll probably do is
  90       --  allocate a new hash table that has the minimum size necessary,
  91       --  instead of allocating a new hash table whose size exactly matches
  92       --  that of the source.  (See the assignment that immediately precedes
  93       --  these comments.)  What we really need is a special Assign operation
  94       --  (not unlike what we have already for Vector) that allows the user to
  95       --  choose the capacity of the target.
  96       --  END NOTE.
  97
  98       for Src_Index in Src_Buckets'Range loop
  99          Src_Node := Src_Buckets (Src_Index);
 100
 101          if Src_Node /= null then
 102             declare
 103                Dst_Node : constant Node_Access := Copy_Node (Src_Node);
 104
 105                --   See note above
 106
 107                pragma Assert (Index (HT, Dst_Node) = Src_Index);
 108
 109             begin
 110                HT.Buckets (Src_Index) := Dst_Node;
 111                HT.Length := HT.Length + 1;
 112
 113                Dst_Prev := Dst_Node;
 114             end;
 115
 116             Src_Node := Next (Src_Node);
 117             while Src_Node /= null loop
 118                declare
 119                   Dst_Node : constant Node_Access := Copy_Node (Src_Node);
 120
 121                   --  See note above
 122
 123                   pragma Assert (Index (HT, Dst_Node) = Src_Index);
 124
 125                begin
 126                   Set_Next (Node => Dst_Prev, Next => Dst_Node);
 127                   HT.Length := HT.Length + 1;
 128
 129                   Dst_Prev := Dst_Node;
 130                end;
 131
 132                Src_Node := Next (Src_Node);
 133             end loop;
 134          end if;
 135       end loop;
 136
 137       pragma Assert (HT.Length = N);
 138    end Adjust;
 139
 140    --------------
 141    -- Capacity --
 142    --------------
 143
 144    function Capacity (HT : Hash_Table_Type) return Count_Type is
 145    begin
 146       if HT.Buckets = null then
 147          return 0;
 148       end if;
 149
 150       return HT.Buckets'Length;
 151    end Capacity;
 152
 153    -----------
 154    -- Clear --
 155    -----------
 156
 157    procedure Clear (HT : in out Hash_Table_Type) is
 158       Index : Hash_Type := 0;
 159       Node  : Node_Access;
 160
 161    begin
 162       if HT.Busy > 0 then
 163          raise Program_Error;
 164       end if;
 165
 166       while HT.Length > 0 loop
 167          while HT.Buckets (Index) = null loop
 168             Index := Index + 1;
 169          end loop;
 170
 171          declare
 172             Bucket : Node_Access renames HT.Buckets (Index);
 173          begin
 174             loop
 175                Node := Bucket;
 176                Bucket := Next (Bucket);
 177                HT.Length := HT.Length - 1;
 178                Free (Node);
 179                exit when Bucket = null;
 180             end loop;
 181          end;
 182       end loop;
 183    end Clear;
 184
 185    ---------------------------
 186    -- Delete_Node_Sans_Free --
 187    ---------------------------
 188
 189    procedure Delete_Node_Sans_Free
 190      (HT : in out Hash_Table_Type;
 191       X  : Node_Access)
 192    is
 193       pragma Assert (X /= null);
 194
 195       Indx : Hash_Type;
 196       Prev : Node_Access;
 197       Curr : Node_Access;
 198
 199    begin
 200       if HT.Length = 0 then
 201          raise Program_Error;
 202       end if;
 203
 204       Indx := Index (HT, X);
 205       Prev := HT.Buckets (Indx);
 206
 207       if Prev = null then
 208          raise Program_Error;
 209       end if;
 210
 211       if Prev = X then
 212          HT.Buckets (Indx) := Next (Prev);
 213          HT.Length := HT.Length - 1;
 214          return;
 215       end if;
 216
 217       if HT.Length = 1 then
 218          raise Program_Error;
 219       end if;
 220
 221       loop
 222          Curr := Next (Prev);
 223
 224          if Curr = null then
 225             raise Program_Error;
 226          end if;
 227
 228          if Curr = X then
 229             Set_Next (Node => Prev, Next => Next (Curr));
 230             HT.Length := HT.Length - 1;
 231             return;
 232          end if;
 233
 234          Prev := Curr;
 235       end loop;
 236    end Delete_Node_Sans_Free;
 237
 238    --------------
 239    -- Finalize --
 240    --------------
 241
 242    procedure Finalize (HT : in out Hash_Table_Type) is
 243    begin
 244       Clear (HT);
 245       Free (HT.Buckets);
 246    end Finalize;
 247
 248    -----------
 249    -- First --
 250    -----------
 251
 252    function First (HT : Hash_Table_Type) return Node_Access is
 253       Indx : Hash_Type;
 254
 255    begin
 256       if HT.Length = 0 then
 257          return null;
 258       end if;
 259
 260       Indx := HT.Buckets'First;
 261       loop
 262          if HT.Buckets (Indx) /= null then
 263             return HT.Buckets (Indx);
 264          end if;
 265
 266          Indx := Indx + 1;
 267       end loop;
 268    end First;
 269
 270    ---------------------
 271    -- Free_Hash_Table --
 272    ---------------------
 273
 274    procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
 275       Node : Node_Access;
 276
 277    begin
 278       if Buckets = null then
 279          return;
 280       end if;
 281
 282       for J in Buckets'Range loop
 283          while Buckets (J) /= null loop
 284             Node := Buckets (J);
 285             Buckets (J) := Next (Node);
 286             Free (Node);
 287          end loop;
 288       end loop;
 289
 290       Free (Buckets);
 291    end Free_Hash_Table;
 292
 293    -------------------
 294    -- Generic_Equal --
 295    -------------------
 296
 297    function Generic_Equal
 298      (L, R : Hash_Table_Type) return Boolean is
 299
 300       L_Index : Hash_Type;
 301       L_Node  : Node_Access;
 302
 303       N : Count_Type;
 304
 305    begin
 306       if L'Address = R'Address then
 307          return True;
 308       end if;
 309
 310       if L.Length /= R.Length then
 311          return False;
 312       end if;
 313
 314       if L.Length = 0 then
 315          return True;
 316       end if;
 317
 318       L_Index := 0;
 319
 320       loop
 321          L_Node := L.Buckets (L_Index);
 322          exit when L_Node /= null;
 323          L_Index := L_Index + 1;
 324       end loop;
 325
 326       N := L.Length;
 327
 328       loop
 329          if not Find (HT => R, Key => L_Node) then
 330             return False;
 331          end if;
 332
 333          N := N - 1;
 334
 335          L_Node := Next (L_Node);
 336
 337          if L_Node = null then
 338             if N = 0 then
 339                return True;
 340             end if;
 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       Busy : Natural renames HT'Unrestricted_Access.all.Busy;
 357
 358    begin
 359       if HT.Length = 0 then
 360          return;
 361       end if;
 362
 363       Busy := Busy + 1;
 364
 365       declare
 366          Node : Node_Access;
 367       begin
 368          for Indx in HT.Buckets'Range loop
 369             Node := HT.Buckets (Indx);
 370             while Node /= null loop
 371                Process (Node);
 372                Node := Next (Node);
 373             end loop;
 374          end loop;
 375       exception
 376          when others =>
 377             Busy := Busy - 1;
 378             raise;
 379       end;
 380
 381       Busy := Busy - 1;
 382    end Generic_Iteration;
 383
 384    ------------------
 385    -- Generic_Read --
 386    ------------------
 387
 388    procedure Generic_Read
 389      (Stream : access Root_Stream_Type'Class;
 390       HT     : out Hash_Table_Type)
 391    is
 392       X, Y : Node_Access;
 393
 394       Last, I : Hash_Type;
 395       N, M    : Count_Type'Base;
 396
 397    begin
 398       Clear (HT);
 399
 400       Hash_Type'Read (Stream, Last);
 401
 402       Count_Type'Base'Read (Stream, N);
 403       pragma Assert (N >= 0);
 404
 405       if N = 0 then
 406          return;
 407       end if;
 408
 409       if HT.Buckets = null
 410         or else HT.Buckets'Last /= Last
 411       then
 412          Free (HT.Buckets);
 413          HT.Buckets := new Buckets_Type (0 .. Last);
 414       end if;
 415
 416       --  TODO: should we rewrite this algorithm so that it doesn't
 417       --  depend on preserving the exactly length of the hash table
 418       --  array?  We would prefer to not have to (re)allocate a
 419       --  buckets array (the array that HT already has might be large
 420       --  enough), and to not have to stream the count of the number
 421       --  of nodes in each bucket.  The algorithm below is vestigial,
 422       --  as it was written prior to the meeting in Palma, when the
 423       --  semantics of equality were changed (and which obviated the
 424       --  need to preserve the hash table length).
 425
 426       loop
 427          Hash_Type'Read (Stream, I);
 428          pragma Assert (I in HT.Buckets'Range);
 429          pragma Assert (HT.Buckets (I) = null);
 430
 431          Count_Type'Base'Read (Stream, M);
 432          pragma Assert (M >= 1);
 433          pragma Assert (M <= N);
 434
 435          HT.Buckets (I) := New_Node (Stream);
 436          pragma Assert (HT.Buckets (I) /= null);
 437          pragma Assert (Next (HT.Buckets (I)) = null);
 438
 439          Y := HT.Buckets (I);
 440
 441          HT.Length := HT.Length + 1;
 442
 443          for J in Count_Type range 2 .. M loop
 444             X := New_Node (Stream);
 445             pragma Assert (X /= null);
 446             pragma Assert (Next (X) = null);
 447
 448             Set_Next (Node => Y, Next => X);
 449             Y := X;
 450
 451             HT.Length := HT.Length + 1;
 452          end loop;
 453
 454          N := N - M;
 455
 456          exit when N = 0;
 457       end loop;
 458    end Generic_Read;
 459
 460    -------------------
 461    -- Generic_Write --
 462    -------------------
 463
 464    procedure Generic_Write
 465      (Stream : access Root_Stream_Type'Class;
 466       HT     : Hash_Table_Type)
 467    is
 468       M : Count_Type'Base;
 469       X : Node_Access;
 470
 471    begin
 472       if HT.Buckets = null then
 473          Hash_Type'Write (Stream, 0);
 474       else
 475          Hash_Type'Write (Stream, HT.Buckets'Last);
 476       end if;
 477
 478       Count_Type'Base'Write (Stream, HT.Length);
 479
 480       if HT.Length = 0 then
 481          return;
 482       end if;
 483
 484       --  TODO: see note in Generic_Read???
 485
 486       for Indx in HT.Buckets'Range loop
 487          X := HT.Buckets (Indx);
 488
 489          if X /= null then
 490             M := 1;
 491             loop
 492                X := Next (X);
 493                exit when X = null;
 494                M := M + 1;
 495             end loop;
 496
 497             Hash_Type'Write (Stream, Indx);
 498             Count_Type'Base'Write (Stream, M);
 499
 500             X := HT.Buckets (Indx);
 501             for J in Count_Type range 1 .. M loop
 502                Write (Stream, X);
 503                X := Next (X);
 504             end loop;
 505
 506             pragma Assert (X = null);
 507          end if;
 508       end loop;
 509    end Generic_Write;
 510
 511    -----------
 512    -- Index --
 513    -----------
 514
 515    function Index
 516      (Buckets : Buckets_Type;
 517       Node    : Node_Access) return Hash_Type is
 518    begin
 519       return Hash_Node (Node) mod Buckets'Length;
 520    end Index;
 521
 522    function Index
 523      (Hash_Table : Hash_Table_Type;
 524       Node       : Node_Access) return Hash_Type is
 525    begin
 526       return Index (Hash_Table.Buckets.all, Node);
 527    end Index;
 528
 529    ----------
 530    -- Move --
 531    ----------
 532
 533    procedure Move (Target, Source : in out Hash_Table_Type) is
 534    begin
 535       if Target'Address = Source'Address then
 536          return;
 537       end if;
 538
 539       if Source.Busy > 0 then
 540          raise Program_Error;
 541       end if;
 542
 543       Clear (Target);
 544
 545       declare
 546          Buckets : constant Buckets_Access := Target.Buckets;
 547       begin
 548          Target.Buckets := Source.Buckets;
 549          Source.Buckets := Buckets;
 550       end;
 551
 552       Target.Length := Source.Length;
 553       Source.Length := 0;
 554    end Move;
 555
 556    ----------
 557    -- Next --
 558    ----------
 559
 560    function Next
 561      (HT   : Hash_Table_Type;
 562       Node : Node_Access) return Node_Access
 563    is
 564       Result : Node_Access := Next (Node);
 565
 566    begin
 567       if Result /= null then
 568          return Result;
 569       end if;
 570
 571       for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop
 572          Result := HT.Buckets (Indx);
 573
 574          if Result /= null then
 575             return Result;
 576          end if;
 577       end loop;
 578
 579       return null;
 580    end Next;
 581
 582    ----------------------
 583    -- Reserve_Capacity --
 584    ----------------------
 585
 586    procedure Reserve_Capacity
 587      (HT : in out Hash_Table_Type;
 588       N  : Count_Type)
 589    is
 590       NN : Hash_Type;
 591
 592    begin
 593       if HT.Buckets = null then
 594          if N > 0 then
 595             NN := Prime_Numbers.To_Prime (N);
 596             HT.Buckets := new Buckets_Type (0 .. NN - 1);
 597          end if;
 598
 599          return;
 600       end if;
 601
 602       if HT.Length = 0 then
 603          if N = 0 then
 604             Free (HT.Buckets);
 605             return;
 606          end if;
 607
 608          if N = HT.Buckets'Length then
 609             return;
 610          end if;
 611
 612          NN := Prime_Numbers.To_Prime (N);
 613
 614          if NN = HT.Buckets'Length then
 615             return;
 616          end if;
 617
 618          declare
 619             X : Buckets_Access := HT.Buckets;
 620          begin
 621             HT.Buckets := new Buckets_Type (0 .. NN - 1);
 622             Free (X);
 623          end;
 624
 625          return;
 626       end if;
 627
 628       if N = HT.Buckets'Length then
 629          return;
 630       end if;
 631
 632       if N < HT.Buckets'Length then
 633          if HT.Length >= HT.Buckets'Length then
 634             return;
 635          end if;
 636
 637          NN := Prime_Numbers.To_Prime (HT.Length);
 638
 639          if NN >= HT.Buckets'Length then
 640             return;
 641          end if;
 642
 643       else
 644          NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
 645
 646          if NN = HT.Buckets'Length then -- can't expand any more
 647             return;
 648          end if;
 649       end if;
 650
 651       if HT.Busy > 0 then
 652          raise Program_Error;
 653       end if;
 654
 655       Rehash : declare
 656          Dst_Buckets : Buckets_Access := new Buckets_Type (0 .. NN - 1);
 657          Src_Buckets : Buckets_Access := HT.Buckets;
 658
 659          L : Count_Type renames HT.Length;
 660          LL : constant Count_Type := L;
 661
 662          Src_Index : Hash_Type := Src_Buckets'First;
 663
 664       begin
 665          while L > 0 loop
 666             declare
 667                Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
 668
 669             begin
 670                while Src_Bucket /= null loop
 671                   declare
 672                      Src_Node : constant Node_Access := Src_Bucket;
 673
 674                      Dst_Index : constant Hash_Type :=
 675                        Index (Dst_Buckets.all, Src_Node);
 676
 677                      Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
 678
 679                   begin
 680                      Src_Bucket := Next (Src_Node);
 681
 682                      Set_Next (Src_Node, Dst_Bucket);
 683
 684                      Dst_Bucket := Src_Node;
 685                   end;
 686
 687                   pragma Assert (L > 0);
 688                   L := L - 1;
 689                end loop;
 690             exception
 691                when others =>
 692                   --  If there's an error computing a hash value during a
 693                   --  rehash, then AI-302 says the nodes "become lost."  The
 694                   --  issue is whether to actually deallocate these lost nodes,
 695                   --  since they might be designated by extant cursors.  Here
 696                   --  we decide to deallocate the nodes, since it's better to
 697                   --  solve real problems (storage consumption) rather than
 698                   --  imaginary ones (the user might, or might not, dereference
 699                   --  a cursor designating a node that has been deallocated),
 700                   --  and because we have a way to vet a dangling cursor
 701                   --  reference anyway, and hence can actually detect the
 702                   --  problem.
 703
 704                   for Dst_Index in Dst_Buckets'Range loop
 705                      declare
 706                         B : Node_Access renames Dst_Buckets (Dst_Index);
 707                         X : Node_Access;
 708                      begin
 709                         while B /= null loop
 710                            X := B;
 711                            B := Next (X);
 712                            Free (X);
 713                         end loop;
 714                      end;
 715                   end loop;
 716
 717                   Free (Dst_Buckets);
 718                   raise Program_Error;
 719             end;
 720
 721             Src_Index := Src_Index + 1;
 722          end loop;
 723
 724          HT.Buckets := Dst_Buckets;
 725          HT.Length := LL;
 726
 727          Free (Src_Buckets);
 728       end Rehash;
 729    end Reserve_Capacity;
 730
 731 end Ada.Containers.Hash_Tables.Generic_Operations;