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 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 --  This body needs commenting ???
  33
  34 with Ada.Containers.Prime_Numbers;
  35 with Ada.Unchecked_Deallocation;
  36
  37 with System;  use type System.Address;
  38
  39 package body Ada.Containers.Hash_Tables.Generic_Operations is
  40
  41    procedure Free is
  42      new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);
  43
  44    -----------------------
  45    -- Local Subprograms --
  46    -----------------------
  47
  48    procedure Rehash
  49      (HT   : in out Hash_Table_Type;
  50       Size : Hash_Type);
  51
  52    ------------
  53    -- Adjust --
  54    ------------
  55
  56    procedure Adjust (HT : in out Hash_Table_Type) is
  57       Src_Buckets : constant Buckets_Access := HT.Buckets;
  58       N           : constant Count_Type := HT.Length;
  59       Src_Node    : Node_Access;
  60       Dst_Prev    : Node_Access;
  61
  62    begin
  63       HT.Buckets := null;
  64       HT.Length := 0;
  65
  66       if N = 0 then
  67          return;
  68       end if;
  69
  70       HT.Buckets := new Buckets_Type (Src_Buckets'Range);
  71
  72       --  Probably we have to duplicate the Size (Src), too, in order
  73       --  to guarantee that
  74
  75       --    Dst := Src;
  76       --    Dst = Src is true
  77
  78       --  The only quirk is that we depend on the hash value of a dst key
  79       --  to be the same as the src key from which it was copied.
  80       --  If we relax the requirement that the hash value must be the
  81       --  same, then of course we can't guarantee that following
  82       --  assignment that Dst = Src is true ???
  83
  84       for Src_Index in Src_Buckets'Range loop
  85          Src_Node := Src_Buckets (Src_Index);
  86
  87          if Src_Node /= Null_Node then
  88             declare
  89                Dst_Node : constant Node_Access := Copy_Node (Src_Node);
  90
  91                --   See note above
  92
  93                pragma Assert (Index (HT, Dst_Node) = Src_Index);
  94
  95             begin
  96                HT.Buckets (Src_Index) := Dst_Node;
  97                HT.Length := HT.Length + 1;
  98
  99                Dst_Prev := Dst_Node;
 100             end;
 101
 102             Src_Node := Next (Src_Node);
 103             while Src_Node /= Null_Node loop
 104                declare
 105                   Dst_Node : constant Node_Access := Copy_Node (Src_Node);
 106
 107                   --  See note above
 108
 109                   pragma Assert (Index (HT, Dst_Node) = Src_Index);
 110
 111                begin
 112                   Set_Next (Node => Dst_Prev, Next => Dst_Node);
 113                   HT.Length := HT.Length + 1;
 114
 115                   Dst_Prev := Dst_Node;
 116                end;
 117
 118                Src_Node := Next (Src_Node);
 119             end loop;
 120          end if;
 121       end loop;
 122
 123       pragma Assert (HT.Length = N);
 124    end Adjust;
 125
 126    --------------
 127    -- Capacity --
 128    --------------
 129
 130    function Capacity (HT : Hash_Table_Type) return Count_Type is
 131    begin
 132       if HT.Buckets = null then
 133          return 0;
 134       end if;
 135
 136       return HT.Buckets'Length;
 137    end Capacity;
 138
 139    -----------
 140    -- Clear --
 141    -----------
 142
 143    procedure Clear (HT : in out Hash_Table_Type) is
 144       Index : Hash_Type := 0;
 145       Node  : Node_Access;
 146
 147    begin
 148       while HT.Length > 0 loop
 149          while HT.Buckets (Index) = Null_Node loop
 150             Index := Index + 1;
 151          end loop;
 152
 153          declare
 154             Bucket : Node_Access renames HT.Buckets (Index);
 155          begin
 156             loop
 157                Node := Bucket;
 158                Bucket := Next (Bucket);
 159                HT.Length := HT.Length - 1;
 160                Free (Node);
 161                exit when Bucket = Null_Node;
 162             end loop;
 163          end;
 164       end loop;
 165    end Clear;
 166
 167    ---------------------------
 168    -- Delete_Node_Sans_Free --
 169    ---------------------------
 170
 171    procedure Delete_Node_Sans_Free
 172      (HT : in out Hash_Table_Type;
 173       X  : Node_Access)
 174    is
 175       pragma Assert (X /= Null_Node);
 176
 177       Indx : Hash_Type;
 178       Prev : Node_Access;
 179       Curr : Node_Access;
 180
 181    begin
 182       if HT.Length = 0 then
 183          raise Program_Error;
 184       end if;
 185
 186       Indx := Index (HT, X);
 187       Prev := HT.Buckets (Indx);
 188
 189       if Prev = Null_Node then
 190          raise Program_Error;
 191       end if;
 192
 193       if Prev = X then
 194          HT.Buckets (Indx) := Next (Prev);
 195          HT.Length := HT.Length - 1;
 196          return;
 197       end if;
 198
 199       if HT.Length = 1 then
 200          raise Program_Error;
 201       end if;
 202
 203       loop
 204          Curr := Next (Prev);
 205
 206          if Curr = Null_Node then
 207             raise Program_Error;
 208          end if;
 209
 210          if Curr = X then
 211             Set_Next (Node => Prev, Next => Next (Curr));
 212             HT.Length := HT.Length - 1;
 213             return;
 214          end if;
 215
 216          Prev := Curr;
 217       end loop;
 218    end Delete_Node_Sans_Free;
 219
 220    ---------------------
 221    -- Ensure_Capacity --
 222    ---------------------
 223
 224    procedure Ensure_Capacity
 225      (HT : in out Hash_Table_Type;
 226       N  : Count_Type)
 227    is
 228       NN : Hash_Type;
 229
 230    begin
 231       if N = 0 then
 232          if HT.Length = 0 then
 233             Free (HT.Buckets);
 234
 235          elsif HT.Length < HT.Buckets'Length then
 236             NN := Prime_Numbers.To_Prime (HT.Length);
 237
 238             --  ASSERT: NN >= HT.Length
 239
 240             if NN < HT.Buckets'Length then
 241                Rehash (HT, Size => NN);
 242             end if;
 243          end if;
 244
 245          return;
 246       end if;
 247
 248       if HT.Buckets = null then
 249          NN := Prime_Numbers.To_Prime (N);
 250
 251          --  ASSERT: NN >= N
 252
 253          Rehash (HT, Size => NN);
 254          return;
 255       end if;
 256
 257       if N <= HT.Length then
 258          if HT.Length >= HT.Buckets'Length then
 259             return;
 260          end if;
 261
 262          NN := Prime_Numbers.To_Prime (HT.Length);
 263
 264          --  ASSERT: NN >= HT.Length
 265
 266          if NN < HT.Buckets'Length then
 267             Rehash (HT, Size => NN);
 268          end if;
 269
 270          return;
 271       end if;
 272
 273       --  ASSERT: N > HT.Length
 274
 275       if N = HT.Buckets'Length then
 276          return;
 277       end if;
 278
 279       NN := Prime_Numbers.To_Prime (N);
 280
 281       --  ASSERT: NN >= N
 282       --  ASSERT: NN > HT.Length
 283
 284       if NN /= HT.Buckets'Length then
 285          Rehash (HT, Size => NN);
 286       end if;
 287    end Ensure_Capacity;
 288
 289    --------------
 290    -- Finalize --
 291    --------------
 292
 293    procedure Finalize (HT : in out Hash_Table_Type) is
 294    begin
 295       Clear (HT);
 296       Free (HT.Buckets);
 297    end Finalize;
 298
 299    -----------
 300    -- First --
 301    -----------
 302
 303    function First (HT : Hash_Table_Type) return Node_Access is
 304       Indx : Hash_Type;
 305
 306    begin
 307       if HT.Length = 0 then
 308          return Null_Node;
 309       end if;
 310
 311       Indx := HT.Buckets'First;
 312       loop
 313          if HT.Buckets (Indx) /= Null_Node then
 314             return HT.Buckets (Indx);
 315          end if;
 316
 317          Indx := Indx + 1;
 318       end loop;
 319    end First;
 320
 321    ---------------------
 322    -- Free_Hash_Table --
 323    ---------------------
 324
 325    procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
 326       Node : Node_Access;
 327
 328    begin
 329       if Buckets = null then
 330          return;
 331       end if;
 332
 333       for J in Buckets'Range loop
 334          while Buckets (J) /= Null_Node loop
 335             Node := Buckets (J);
 336             Buckets (J) := Next (Node);
 337             Free (Node);
 338          end loop;
 339       end loop;
 340
 341       Free (Buckets);
 342    end Free_Hash_Table;
 343
 344    -------------------
 345    -- Generic_Equal --
 346    -------------------
 347
 348    function Generic_Equal
 349      (L, R : Hash_Table_Type) return Boolean is
 350
 351       L_Index : Hash_Type;
 352       L_Node  : Node_Access;
 353
 354       N : Count_Type;
 355
 356    begin
 357       if L'Address = R'Address then
 358          return True;
 359       end if;
 360
 361       if L.Length /= R.Length then
 362          return False;
 363       end if;
 364
 365       if L.Length = 0 then
 366          return True;
 367       end if;
 368
 369       L_Index := 0;
 370
 371       loop
 372          L_Node := L.Buckets (L_Index);
 373          exit when L_Node /= Null_Node;
 374          L_Index := L_Index + 1;
 375       end loop;
 376
 377       N := L.Length;
 378
 379       loop
 380          if not Find (HT => R, Key => L_Node) then
 381             return False;
 382          end if;
 383
 384          N := N - 1;
 385
 386          L_Node := Next (L_Node);
 387
 388          if L_Node = Null_Node then
 389             if N = 0 then
 390                return True;
 391             end if;
 392
 393             loop
 394                L_Index := L_Index + 1;
 395                L_Node := L.Buckets (L_Index);
 396                exit when L_Node /= Null_Node;
 397             end loop;
 398          end if;
 399       end loop;
 400    end Generic_Equal;
 401
 402    -----------------------
 403    -- Generic_Iteration --
 404    -----------------------
 405
 406    procedure Generic_Iteration (HT : Hash_Table_Type) is
 407       Node : Node_Access;
 408
 409    begin
 410       if HT.Buckets = null
 411         or else HT.Length = 0
 412       then
 413          return;
 414       end if;
 415
 416       for Indx in HT.Buckets'Range loop
 417          Node := HT.Buckets (Indx);
 418          while Node /= Null_Node loop
 419             Process (Node);
 420             Node := Next (Node);
 421          end loop;
 422       end loop;
 423    end Generic_Iteration;
 424
 425    ------------------
 426    -- Generic_Read --
 427    ------------------
 428
 429    procedure Generic_Read
 430      (Stream : access Root_Stream_Type'Class;
 431       HT     : out Hash_Table_Type)
 432    is
 433       X, Y : Node_Access;
 434
 435       Last, I : Hash_Type;
 436       N, M    : Count_Type'Base;
 437
 438    begin
 439       --  As with the sorted set, it's not clear whether read is allowed to
 440       --  have side effect if it fails. For now, we assume side effects are
 441       --  allowed since it simplifies the algorithm ???
 442       --
 443       Clear (HT);
 444
 445       declare
 446          B : Buckets_Access := HT.Buckets;
 447       begin
 448          HT.Buckets := null;
 449          HT.Length := 0;
 450          Free (B); -- can this fail???
 451       end;
 452
 453       Hash_Type'Read (Stream, Last);
 454
 455       if Last /= 0 then
 456          HT.Buckets := new Buckets_Type (0 .. Last);
 457       end if;
 458
 459       Count_Type'Base'Read (Stream, N);
 460       pragma Assert (N >= 0);
 461       while N > 0 loop
 462          Hash_Type'Read (Stream, I);
 463          pragma Assert (I in HT.Buckets'Range);
 464          pragma Assert (HT.Buckets (I) = Null_Node);
 465
 466          Count_Type'Base'Read (Stream, M);
 467          pragma Assert (M >= 1);
 468          pragma Assert (M <= N);
 469
 470          HT.Buckets (I) := New_Node (Stream);
 471          pragma Assert (HT.Buckets (I) /= Null_Node);
 472          pragma Assert (Next (HT.Buckets (I)) = Null_Node);
 473
 474          Y := HT.Buckets (I);
 475
 476          HT.Length := HT.Length + 1;
 477
 478          for J in Count_Type range 2 .. M loop
 479             X := New_Node (Stream);
 480             pragma Assert (X /= Null_Node);
 481             pragma Assert (Next (X) = Null_Node);
 482
 483             Set_Next (Node => Y, Next => X);
 484             Y := X;
 485
 486             HT.Length := HT.Length + 1;
 487          end loop;
 488
 489          N := N - M;
 490       end loop;
 491    end Generic_Read;
 492
 493    -------------------
 494    -- Generic_Write --
 495    -------------------
 496
 497    procedure Generic_Write
 498      (Stream : access Root_Stream_Type'Class;
 499       HT     : Hash_Table_Type)
 500    is
 501       M : Count_Type'Base;
 502       X : Node_Access;
 503
 504    begin
 505       if HT.Buckets = null then
 506          Hash_Type'Write (Stream, 0);
 507       else
 508          Hash_Type'Write (Stream, HT.Buckets'Last);
 509       end if;
 510
 511       Count_Type'Base'Write (Stream, HT.Length);
 512
 513       if HT.Length = 0 then
 514          return;
 515       end if;
 516
 517       for Indx in HT.Buckets'Range loop
 518          X := HT.Buckets (Indx);
 519
 520          if X /= Null_Node then
 521             M := 1;
 522             loop
 523                X := Next (X);
 524                exit when X = Null_Node;
 525                M := M + 1;
 526             end loop;
 527
 528             Hash_Type'Write (Stream, Indx);
 529             Count_Type'Base'Write (Stream, M);
 530
 531             X := HT.Buckets (Indx);
 532             for J in Count_Type range 1 .. M loop
 533                Write (Stream, X);
 534                X := Next (X);
 535             end loop;
 536
 537             pragma Assert (X = Null_Node);
 538          end if;
 539       end loop;
 540    end Generic_Write;
 541
 542    -----------
 543    -- Index --
 544    -----------
 545
 546    function Index
 547      (Buckets : Buckets_Type;
 548       Node    : Node_Access) return Hash_Type is
 549    begin
 550       return Hash_Node (Node) mod Buckets'Length;
 551    end Index;
 552
 553    function Index
 554      (Hash_Table : Hash_Table_Type;
 555       Node       : Node_Access) return Hash_Type is
 556    begin
 557       return Index (Hash_Table.Buckets.all, Node);
 558    end Index;
 559
 560    ----------
 561    -- Move --
 562    ----------
 563
 564    procedure Move (Target, Source : in out Hash_Table_Type) is
 565    begin
 566       if Target'Address = Source'Address then
 567          return;
 568       end if;
 569
 570       if Target.Length > 0 then
 571          raise Constraint_Error;
 572       end if;
 573
 574       Free (Target.Buckets);
 575
 576       Target.Buckets := Source.Buckets;
 577       Source.Buckets := null;
 578
 579       Target.Length := Source.Length;
 580       Source.Length := 0;
 581    end Move;
 582
 583    ----------
 584    -- Next --
 585    ----------
 586
 587    function Next
 588      (HT   : Hash_Table_Type;
 589       Node : Node_Access) return Node_Access
 590    is
 591       Result : Node_Access := Next (Node);
 592
 593    begin
 594       if Result /= Null_Node then
 595          return Result;
 596       end if;
 597
 598       for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop
 599          Result := HT.Buckets (Indx);
 600
 601          if Result /= Null_Node then
 602             return Result;
 603          end if;
 604       end loop;
 605
 606       return Null_Node;
 607    end Next;
 608
 609    ------------
 610    -- Rehash --
 611    ------------
 612
 613    procedure Rehash
 614      (HT   : in out Hash_Table_Type;
 615       Size : Hash_Type)
 616    is
 617       subtype Buckets_Range is Hash_Type range 0 .. Size - 1;
 618
 619       Dst_Buckets : Buckets_Access := new Buckets_Type (Buckets_Range);
 620       Src_Buckets : Buckets_Access := HT.Buckets;
 621
 622       L  : Count_Type renames HT.Length;
 623       LL : constant Count_Type := L;
 624
 625    begin
 626       if Src_Buckets = null then
 627          pragma Assert (L = 0);
 628          HT.Buckets := Dst_Buckets;
 629          return;
 630       end if;
 631
 632       if L = 0 then
 633          HT.Buckets := Dst_Buckets;
 634          Free (Src_Buckets);
 635          return;
 636       end if;
 637
 638       --  We might want to change this to iter from 1 .. L instead ???
 639
 640       for Src_Index in Src_Buckets'Range loop
 641
 642          declare
 643             Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
 644          begin
 645             while Src_Bucket /= Null_Node loop
 646                declare
 647                   Src_Node   : constant Node_Access := Src_Bucket;
 648                   Dst_Index  : constant Hash_Type :=
 649                                  Index (Dst_Buckets.all, Src_Node);
 650                   Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
 651                begin
 652                   Src_Bucket := Next (Src_Node);
 653                   Set_Next (Src_Node, Dst_Bucket);
 654                   Dst_Bucket := Src_Node;
 655                end;
 656
 657                pragma Assert (L > 0);
 658                L := L - 1;
 659
 660             end loop;
 661
 662          exception
 663             when others =>
 664
 665                --  Not clear that we can deallocate the nodes,
 666                --  because they may be designated by outstanding
 667                --  iterators.  Which means they're now lost... ???
 668
 669                --                 for J in NB'Range loop
 670                --                    declare
 671                --                       Dst : Node_Access renames NB (J);
 672                --                       X   : Node_Access;
 673                --                    begin
 674                --                       while Dst /= Null_Node loop
 675                --                          X := Dst;
 676                --                          Dst := Succ (Dst);
 677                --                          Free (X);
 678                --                       end loop;
 679                --                    end;
 680                --                 end loop;
 681
 682
 683                Free (Dst_Buckets);
 684                raise;
 685          end;
 686
 687          --  exit when L = 0;
 688          --  need to bother???
 689
 690       end loop;
 691
 692       pragma Assert (L = 0);
 693
 694       HT.Buckets := Dst_Buckets;
 695       HT.Length := LL;
 696
 697       Free (Src_Buckets);
 698    end Rehash;
 699
 700 end Ada.Containers.Hash_Tables.Generic_Operations;
 701