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