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;
 137       end if;
 138
 139       while HT.Length > 0 loop
 140          while HT.Buckets (Index) = null loop
 141             Index := Index + 1;
 142          end loop;
 143
 144          declare
 145             Bucket : Node_Access renames HT.Buckets (Index);
 146          begin
 147             loop
 148                Node := Bucket;
 149                Bucket := Next (Bucket);
 150                HT.Length := HT.Length - 1;
 151                Free (Node);
 152                exit when Bucket = null;
 153             end loop;
 154          end;
 155       end loop;
 156    end Clear;
 157
 158    ---------------------------
 159    -- Delete_Node_Sans_Free --
 160    ---------------------------
 161
 162    procedure Delete_Node_Sans_Free
 163      (HT : in out Hash_Table_Type;
 164       X  : Node_Access)
 165    is
 166       pragma Assert (X /= null);
 167
 168       Indx : Hash_Type;
 169       Prev : Node_Access;
 170       Curr : Node_Access;
 171
 172    begin
 173       if HT.Length = 0 then
 174          raise Program_Error;
 175       end if;
 176
 177       Indx := Index (HT, X);
 178       Prev := HT.Buckets (Indx);
 179
 180       if Prev = null then
 181          raise Program_Error;
 182       end if;
 183
 184       if Prev = X then
 185          HT.Buckets (Indx) := Next (Prev);
 186          HT.Length := HT.Length - 1;
 187          return;
 188       end if;
 189
 190       if HT.Length = 1 then
 191          raise Program_Error;
 192       end if;
 193
 194       loop
 195          Curr := Next (Prev);
 196
 197          if Curr = null then
 198             raise Program_Error;
 199          end if;
 200
 201          if Curr = X then
 202             Set_Next (Node => Prev, Next => Next (Curr));
 203             HT.Length := HT.Length - 1;
 204             return;
 205          end if;
 206
 207          Prev := Curr;
 208       end loop;
 209    end Delete_Node_Sans_Free;
 210
 211    --------------
 212    -- Finalize --
 213    --------------
 214
 215    procedure Finalize (HT : in out Hash_Table_Type) is
 216    begin
 217       Clear (HT);
 218       Free (HT.Buckets);
 219    end Finalize;
 220
 221    -----------
 222    -- First --
 223    -----------
 224
 225    function First (HT : Hash_Table_Type) return Node_Access is
 226       Indx : Hash_Type;
 227
 228    begin
 229       if HT.Length = 0 then
 230          return null;
 231       end if;
 232
 233       Indx := HT.Buckets'First;
 234       loop
 235          if HT.Buckets (Indx) /= null then
 236             return HT.Buckets (Indx);
 237          end if;
 238
 239          Indx := Indx + 1;
 240       end loop;
 241    end First;
 242
 243    ---------------------
 244    -- Free_Hash_Table --
 245    ---------------------
 246
 247    procedure Free_Hash_Table (Buckets : in out Buckets_Access) is
 248       Node : Node_Access;
 249
 250    begin
 251       if Buckets = null then
 252          return;
 253       end if;
 254
 255       for J in Buckets'Range loop
 256          while Buckets (J) /= null loop
 257             Node := Buckets (J);
 258             Buckets (J) := Next (Node);
 259             Free (Node);
 260          end loop;
 261       end loop;
 262
 263       Free (Buckets);
 264    end Free_Hash_Table;
 265
 266    -------------------
 267    -- Generic_Equal --
 268    -------------------
 269
 270    function Generic_Equal
 271      (L, R : Hash_Table_Type) return Boolean is
 272
 273       L_Index : Hash_Type;
 274       L_Node  : Node_Access;
 275
 276       N : Count_Type;
 277
 278    begin
 279       if L'Address = R'Address then
 280          return True;
 281       end if;
 282
 283       if L.Length /= R.Length then
 284          return False;
 285       end if;
 286
 287       if L.Length = 0 then
 288          return True;
 289       end if;
 290
 291       L_Index := 0;
 292
 293       loop
 294          L_Node := L.Buckets (L_Index);
 295          exit when L_Node /= null;
 296          L_Index := L_Index + 1;
 297       end loop;
 298
 299       N := L.Length;
 300
 301       loop
 302          if not Find (HT => R, Key => L_Node) then
 303             return False;
 304          end if;
 305
 306          N := N - 1;
 307
 308          L_Node := Next (L_Node);
 309
 310          if L_Node = null then
 311             if N = 0 then
 312                return True;
 313             end if;
 314
 315             loop
 316                L_Index := L_Index + 1;
 317                L_Node := L.Buckets (L_Index);
 318                exit when L_Node /= null;
 319             end loop;
 320          end if;
 321       end loop;
 322    end Generic_Equal;
 323
 324    -----------------------
 325    -- Generic_Iteration --
 326    -----------------------
 327
 328    procedure Generic_Iteration (HT : Hash_Table_Type) is
 329       Node : Node_Access;
 330
 331    begin
 332       if HT.Length = 0 then
 333          return;
 334       end if;
 335
 336       for Indx in HT.Buckets'Range loop
 337          Node := HT.Buckets (Indx);
 338          while Node /= null loop
 339             Process (Node);
 340             Node := Next (Node);
 341          end loop;
 342       end loop;
 343    end Generic_Iteration;
 344
 345    ------------------
 346    -- Generic_Read --
 347    ------------------
 348
 349    procedure Generic_Read
 350      (Stream : access Root_Stream_Type'Class;
 351       HT     : out Hash_Table_Type)
 352    is
 353       N  : Count_Type'Base;
 354       NN : Hash_Type;
 355
 356    begin
 357       Clear (HT);
 358
 359       Count_Type'Base'Read (Stream, N);
 360
 361       if N < 0 then
 362          raise Program_Error;
 363       end if;
 364
 365       if N = 0 then
 366          return;
 367       end if;
 368
 369       if HT.Buckets = null
 370         or else HT.Buckets'Length < N
 371       then
 372          Free (HT.Buckets);
 373          NN := Prime_Numbers.To_Prime (N);
 374          HT.Buckets := new Buckets_Type (0 .. NN - 1);
 375       end if;
 376
 377       for J in 1 .. N loop
 378          declare
 379             Node : constant Node_Access := New_Node (Stream);
 380             Indx : constant Hash_Type := Index (HT, Node);
 381             B    : Node_Access renames HT.Buckets (Indx);
 382          begin
 383             Set_Next (Node => Node, Next => B);
 384             B := Node;
 385          end;
 386
 387          HT.Length := HT.Length + 1;
 388       end loop;
 389    end Generic_Read;
 390
 391    -------------------
 392    -- Generic_Write --
 393    -------------------
 394
 395    procedure Generic_Write
 396      (Stream : access Root_Stream_Type'Class;
 397       HT     : Hash_Table_Type)
 398    is
 399       procedure Write (Node : Node_Access);
 400       pragma Inline (Write);
 401
 402       procedure Write is new Generic_Iteration (Write);
 403
 404       -----------
 405       -- Write --
 406       -----------
 407
 408       procedure Write (Node : Node_Access) is
 409       begin
 410          Write (Stream, Node);
 411       end Write;
 412
 413    begin
 414       Count_Type'Base'Write (Stream, HT.Length);
 415       Write (HT);
 416    end Generic_Write;
 417
 418    -----------
 419    -- Index --
 420    -----------
 421
 422    function Index
 423      (Buckets : Buckets_Type;
 424       Node    : Node_Access) return Hash_Type is
 425    begin
 426       return Hash_Node (Node) mod Buckets'Length;
 427    end Index;
 428
 429    function Index
 430      (Hash_Table : Hash_Table_Type;
 431       Node       : Node_Access) return Hash_Type is
 432    begin
 433       return Index (Hash_Table.Buckets.all, Node);
 434    end Index;
 435
 436    ----------
 437    -- Move --
 438    ----------
 439
 440    procedure Move (Target, Source : in out Hash_Table_Type) is
 441    begin
 442       if Target'Address = Source'Address then
 443          return;
 444       end if;
 445
 446       if Source.Busy > 0 then
 447          raise Program_Error;
 448       end if;
 449
 450       Clear (Target);
 451
 452       declare
 453          Buckets : constant Buckets_Access := Target.Buckets;
 454       begin
 455          Target.Buckets := Source.Buckets;
 456          Source.Buckets := Buckets;
 457       end;
 458
 459       Target.Length := Source.Length;
 460       Source.Length := 0;
 461    end Move;
 462
 463    ----------
 464    -- Next --
 465    ----------
 466
 467    function Next
 468      (HT   : Hash_Table_Type;
 469       Node : Node_Access) return Node_Access
 470    is
 471       Result : Node_Access := Next (Node);
 472
 473    begin
 474       if Result /= null then
 475          return Result;
 476       end if;
 477
 478       for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop
 479          Result := HT.Buckets (Indx);
 480
 481          if Result /= null then
 482             return Result;
 483          end if;
 484       end loop;
 485
 486       return null;
 487    end Next;
 488
 489    ----------------------
 490    -- Reserve_Capacity --
 491    ----------------------
 492
 493    procedure Reserve_Capacity
 494      (HT : in out Hash_Table_Type;
 495       N  : Count_Type)
 496    is
 497       NN : Hash_Type;
 498
 499    begin
 500       if HT.Buckets = null then
 501          if N > 0 then
 502             NN := Prime_Numbers.To_Prime (N);
 503             HT.Buckets := new Buckets_Type (0 .. NN - 1);
 504          end if;
 505
 506          return;
 507       end if;
 508
 509       if HT.Length = 0 then
 510          if N = 0 then
 511             Free (HT.Buckets);
 512             return;
 513          end if;
 514
 515          if N = HT.Buckets'Length then
 516             return;
 517          end if;
 518
 519          NN := Prime_Numbers.To_Prime (N);
 520
 521          if NN = HT.Buckets'Length then
 522             return;
 523          end if;
 524
 525          declare
 526             X : Buckets_Access := HT.Buckets;
 527          begin
 528             HT.Buckets := new Buckets_Type (0 .. NN - 1);
 529             Free (X);
 530          end;
 531
 532          return;
 533       end if;
 534
 535       if N = HT.Buckets'Length then
 536          return;
 537       end if;
 538
 539       if N < HT.Buckets'Length then
 540          if HT.Length >= HT.Buckets'Length then
 541             return;
 542          end if;
 543
 544          NN := Prime_Numbers.To_Prime (HT.Length);
 545
 546          if NN >= HT.Buckets'Length then
 547             return;
 548          end if;
 549
 550       else
 551          NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));
 552
 553          if NN = HT.Buckets'Length then -- can't expand any more
 554             return;
 555          end if;
 556       end if;
 557
 558       if HT.Busy > 0 then
 559          raise Program_Error;
 560       end if;
 561
 562       Rehash : declare
 563          Dst_Buckets : Buckets_Access := new Buckets_Type (0 .. NN - 1);
 564          Src_Buckets : Buckets_Access := HT.Buckets;
 565
 566          L : Count_Type renames HT.Length;
 567          LL : constant Count_Type := L;
 568
 569          Src_Index : Hash_Type := Src_Buckets'First;
 570
 571       begin
 572          while L > 0 loop
 573             declare
 574                Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
 575
 576             begin
 577                while Src_Bucket /= null loop
 578                   declare
 579                      Src_Node : constant Node_Access := Src_Bucket;
 580
 581                      Dst_Index : constant Hash_Type :=
 582                        Index (Dst_Buckets.all, Src_Node);
 583
 584                      Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
 585
 586                   begin
 587                      Src_Bucket := Next (Src_Node);
 588
 589                      Set_Next (Src_Node, Dst_Bucket);
 590
 591                      Dst_Bucket := Src_Node;
 592                   end;
 593
 594                   pragma Assert (L > 0);
 595                   L := L - 1;
 596                end loop;
 597             exception
 598                when others =>
 599                   --  If there's an error computing a hash value during a
 600                   --  rehash, then AI-302 says the nodes "become lost."  The
 601                   --  issue is whether to actually deallocate these lost nodes,
 602                   --  since they might be designated by extant cursors.  Here
 603                   --  we decide to deallocate the nodes, since it's better to
 604                   --  solve real problems (storage consumption) rather than
 605                   --  imaginary ones (the user might, or might not, dereference
 606                   --  a cursor designating a node that has been deallocated),
 607                   --  and because we have a way to vet a dangling cursor
 608                   --  reference anyway, and hence can actually detect the
 609                   --  problem.
 610
 611                   for Dst_Index in Dst_Buckets'Range loop
 612                      declare
 613                         B : Node_Access renames Dst_Buckets (Dst_Index);
 614                         X : Node_Access;
 615                      begin
 616                         while B /= null loop
 617                            X := B;
 618                            B := Next (X);
 619                            Free (X);
 620                         end loop;
 621                      end;
 622                   end loop;
 623
 624                   Free (Dst_Buckets);
 625                   raise Program_Error;
 626             end;
 627
 628             Src_Index := Src_Index + 1;
 629          end loop;
 630
 631          HT.Buckets := Dst_Buckets;
 632          HT.Length := LL;
 633
 634          Free (Src_Buckets);
 635       end Rehash;
 636    end Reserve_Capacity;
 637
 638 end Ada.Containers.Hash_Tables.Generic_Operations;