gcc/ada/a-cbhase.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --    A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ S E T S   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2011, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with Ada.Containers.Hash_Tables.Generic_Bounded_Operations;
  31 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations);
  32
  33 with Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
  34 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
  35
  36 with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
  37
  38 with System; use type System.Address;
  39
  40 package body Ada.Containers.Bounded_Hashed_Sets is
  41
  42    -----------------------
  43    -- Local Subprograms --
  44    -----------------------
  45
  46    function Equivalent_Keys
  47      (Key  : Element_Type;
  48       Node : Node_Type) return Boolean;
  49    pragma Inline (Equivalent_Keys);
  50
  51    function Hash_Node (Node : Node_Type) return Hash_Type;
  52    pragma Inline (Hash_Node);
  53
  54    procedure Insert
  55      (Container : in out Set;
  56       New_Item  : Element_Type;
  57       Node      : out Count_Type;
  58       Inserted  : out Boolean);
  59
  60    function Is_In
  61      (HT  : Set;
  62       Key : Node_Type) return Boolean;
  63    pragma Inline (Is_In);
  64
  65    procedure Set_Element (Node : in out Node_Type; Item : Element_Type);
  66    pragma Inline (Set_Element);
  67
  68    function Next (Node : Node_Type) return Count_Type;
  69    pragma Inline (Next);
  70
  71    procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
  72    pragma Inline (Set_Next);
  73
  74    function Vet (Position : Cursor) return Boolean;
  75
  76    --------------------------
  77    -- Local Instantiations --
  78    --------------------------
  79
  80    package HT_Ops is new Hash_Tables.Generic_Bounded_Operations
  81      (HT_Types  => HT_Types,
  82       Hash_Node => Hash_Node,
  83       Next      => Next,
  84       Set_Next  => Set_Next);
  85
  86    package Element_Keys is new Hash_Tables.Generic_Bounded_Keys
  87      (HT_Types        => HT_Types,
  88       Next            => Next,
  89       Set_Next        => Set_Next,
  90       Key_Type        => Element_Type,
  91       Hash            => Hash,
  92       Equivalent_Keys => Equivalent_Keys);
  93
  94    procedure Replace_Element is
  95       new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element);
  96
  97    ---------
  98    -- "=" --
  99    ---------
 100
 101    function "=" (Left, Right : Set) return Boolean is
 102       function Find_Equal_Key
 103         (R_HT   : Hash_Table_Type'Class;
 104          L_Node : Node_Type) return Boolean;
 105       pragma Inline (Find_Equal_Key);
 106
 107       function Is_Equal is
 108         new HT_Ops.Generic_Equal (Find_Equal_Key);
 109
 110       --------------------
 111       -- Find_Equal_Key --
 112       --------------------
 113
 114       function Find_Equal_Key
 115         (R_HT   : Hash_Table_Type'Class;
 116          L_Node : Node_Type) return Boolean
 117       is
 118          R_Index : constant Hash_Type :=
 119                      Element_Keys.Index (R_HT, L_Node.Element);
 120
 121          R_Node  : Count_Type := R_HT.Buckets (R_Index);
 122
 123       begin
 124          loop
 125             if R_Node = 0 then
 126                return False;
 127             end if;
 128
 129             if L_Node.Element = R_HT.Nodes (R_Node).Element then
 130                return True;
 131             end if;
 132
 133             R_Node := Next (R_HT.Nodes (R_Node));
 134          end loop;
 135       end Find_Equal_Key;
 136
 137    --  Start of processing for "="
 138
 139    begin
 140       return Is_Equal (Left, Right);
 141    end "=";
 142
 143    ------------
 144    -- Assign --
 145    ------------
 146
 147    procedure Assign (Target : in out Set; Source : Set) is
 148       procedure Insert_Element (Source_Node : Count_Type);
 149
 150       procedure Insert_Elements is
 151          new HT_Ops.Generic_Iteration (Insert_Element);
 152
 153       --------------------
 154       -- Insert_Element --
 155       --------------------
 156
 157       procedure Insert_Element (Source_Node : Count_Type) is
 158          N : Node_Type renames Source.Nodes (Source_Node);
 159          X : Count_Type;
 160          B : Boolean;
 161
 162       begin
 163          Insert (Target, N.Element, X, B);
 164          pragma Assert (B);
 165       end Insert_Element;
 166
 167    --  Start of processing for Assign
 168
 169    begin
 170       if Target'Address = Source'Address then
 171          return;
 172       end if;
 173
 174       if Target.Capacity < Source.Length then
 175          raise Capacity_Error
 176            with "Target capacity is less than Source length";
 177       end if;
 178
 179       HT_Ops.Clear (Target);
 180       Insert_Elements (Source);
 181    end Assign;
 182
 183    --------------
 184    -- Capacity --
 185    --------------
 186
 187    function Capacity (Container : Set) return Count_Type is
 188    begin
 189       return Container.Capacity;
 190    end Capacity;
 191
 192    -----------
 193    -- Clear --
 194    -----------
 195
 196    procedure Clear (Container : in out Set) is
 197    begin
 198       HT_Ops.Clear (Container);
 199    end Clear;
 200
 201    --------------
 202    -- Contains --
 203    --------------
 204
 205    function Contains (Container : Set; Item : Element_Type) return Boolean is
 206    begin
 207       return Find (Container, Item) /= No_Element;
 208    end Contains;
 209
 210    ----------
 211    -- Copy --
 212    ----------
 213
 214    function Copy
 215      (Source   : Set;
 216       Capacity : Count_Type := 0;
 217       Modulus  : Hash_Type := 0) return Set
 218    is
 219       C : Count_Type;
 220       M : Hash_Type;
 221
 222    begin
 223       if Capacity = 0 then
 224          C := Source.Length;
 225
 226       elsif Capacity >= Source.Length then
 227          C := Capacity;
 228
 229       else
 230          raise Capacity_Error with "Capacity value too small";
 231       end if;
 232
 233       if Modulus = 0 then
 234          M := Default_Modulus (C);
 235       else
 236          M := Modulus;
 237       end if;
 238
 239       return Target : Set (Capacity => C, Modulus => M) do
 240          Assign (Target => Target, Source => Source);
 241       end return;
 242    end Copy;
 243
 244    ---------------------
 245    -- Default_Modulus --
 246    ---------------------
 247
 248    function Default_Modulus (Capacity : Count_Type) return Hash_Type is
 249    begin
 250       return To_Prime (Capacity);
 251    end Default_Modulus;
 252
 253    ------------
 254    -- Delete --
 255    ------------
 256
 257    procedure Delete
 258      (Container : in out Set;
 259       Item      : Element_Type)
 260    is
 261       X : Count_Type;
 262
 263    begin
 264       Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
 265
 266       if X = 0 then
 267          raise Constraint_Error with "attempt to delete element not in set";
 268       end if;
 269
 270       HT_Ops.Free (Container, X);
 271    end Delete;
 272
 273    procedure Delete
 274      (Container : in out Set;
 275       Position  : in out Cursor)
 276    is
 277    begin
 278       if Position.Node = 0 then
 279          raise Constraint_Error with "Position cursor equals No_Element";
 280       end if;
 281
 282       if Position.Container /= Container'Unrestricted_Access then
 283          raise Program_Error with "Position cursor designates wrong set";
 284       end if;
 285
 286       if Container.Busy > 0 then
 287          raise Program_Error with
 288            "attempt to tamper with cursors (set is busy)";
 289       end if;
 290
 291       pragma Assert (Vet (Position), "bad cursor in Delete");
 292
 293       HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
 294       HT_Ops.Free (Container, Position.Node);
 295
 296       Position := No_Element;
 297    end Delete;
 298
 299    ----------------
 300    -- Difference --
 301    ----------------
 302
 303    procedure Difference
 304      (Target : in out Set;
 305       Source : Set)
 306    is
 307       Tgt_Node, Src_Node : Count_Type;
 308
 309       TN : Nodes_Type renames Target.Nodes;
 310       SN : Nodes_Type renames Source.Nodes;
 311
 312    begin
 313       if Target'Address = Source'Address then
 314          HT_Ops.Clear (Target);
 315          return;
 316       end if;
 317
 318       if Source.Length = 0 then
 319          return;
 320       end if;
 321
 322       if Target.Busy > 0 then
 323          raise Program_Error with
 324            "attempt to tamper with cursors (set is busy)";
 325       end if;
 326
 327       if Source.Length < Target.Length then
 328          Src_Node := HT_Ops.First (Source);
 329          while Src_Node /= 0 loop
 330             Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element);
 331
 332             if Tgt_Node /= 0 then
 333                HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node);
 334                HT_Ops.Free (Target, Tgt_Node);
 335             end if;
 336
 337             Src_Node := HT_Ops.Next (Source, Src_Node);
 338          end loop;
 339
 340       else
 341          Tgt_Node := HT_Ops.First (Target);
 342          while Tgt_Node /= 0 loop
 343             if Is_In (Source, TN (Tgt_Node)) then
 344                declare
 345                   X : constant Count_Type := Tgt_Node;
 346                begin
 347                   Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 348                   HT_Ops.Delete_Node_Sans_Free (Target, X);
 349                   HT_Ops.Free (Target, X);
 350                end;
 351
 352             else
 353                Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 354             end if;
 355          end loop;
 356       end if;
 357    end Difference;
 358
 359    function Difference (Left, Right : Set) return Set is
 360    begin
 361       if Left'Address = Right'Address then
 362          return Empty_Set;
 363       end if;
 364
 365       if Left.Length = 0 then
 366          return Empty_Set;
 367       end if;
 368
 369       if Right.Length = 0 then
 370          return Left;
 371       end if;
 372
 373       return Result : Set (Left.Length, To_Prime (Left.Length)) do
 374          Iterate_Left : declare
 375             procedure Process (L_Node : Count_Type);
 376
 377             procedure Iterate is
 378                new HT_Ops.Generic_Iteration (Process);
 379
 380             -------------
 381             -- Process --
 382             -------------
 383
 384             procedure Process (L_Node : Count_Type) is
 385                N : Node_Type renames Left.Nodes (L_Node);
 386                X : Count_Type;
 387                B : Boolean;
 388
 389             begin
 390                if not Is_In (Right, N) then
 391                   Insert (Result, N.Element, X, B);  --  optimize this ???
 392                   pragma Assert (B);
 393                   pragma Assert (X > 0);
 394                end if;
 395             end Process;
 396
 397          --  Start of processing for Iterate_Left
 398
 399          begin
 400             Iterate (Left);
 401          end Iterate_Left;
 402       end return;
 403    end Difference;
 404
 405    -------------
 406    -- Element --
 407    -------------
 408
 409    function Element (Position : Cursor) return Element_Type is
 410    begin
 411       if Position.Node = 0 then
 412          raise Constraint_Error with "Position cursor equals No_Element";
 413       end if;
 414
 415       pragma Assert (Vet (Position), "bad cursor in function Element");
 416
 417       declare
 418          S : Set renames Position.Container.all;
 419          N : Node_Type renames S.Nodes (Position.Node);
 420
 421       begin
 422          return N.Element;
 423       end;
 424    end Element;
 425
 426    ---------------------
 427    -- Equivalent_Sets --
 428    ---------------------
 429
 430    function Equivalent_Sets (Left, Right : Set) return Boolean is
 431       function Find_Equivalent_Key
 432         (R_HT   : Hash_Table_Type'Class;
 433          L_Node : Node_Type) return Boolean;
 434       pragma Inline (Find_Equivalent_Key);
 435
 436       function Is_Equivalent is
 437          new HT_Ops.Generic_Equal (Find_Equivalent_Key);
 438
 439       -------------------------
 440       -- Find_Equivalent_Key --
 441       -------------------------
 442
 443       function Find_Equivalent_Key
 444         (R_HT   : Hash_Table_Type'Class;
 445          L_Node : Node_Type) return Boolean
 446       is
 447          R_Index : constant Hash_Type :=
 448                      Element_Keys.Index (R_HT, L_Node.Element);
 449
 450          R_Node  : Count_Type := R_HT.Buckets (R_Index);
 451
 452          RN      : Nodes_Type renames R_HT.Nodes;
 453
 454       begin
 455          loop
 456             if R_Node = 0 then
 457                return False;
 458             end if;
 459
 460             if Equivalent_Elements (L_Node.Element, RN (R_Node).Element) then
 461                return True;
 462             end if;
 463
 464             R_Node := HT_Ops.Next (R_HT, R_Node);
 465          end loop;
 466       end Find_Equivalent_Key;
 467
 468    --  Start of processing for Equivalent_Sets
 469
 470    begin
 471       return Is_Equivalent (Left, Right);
 472    end Equivalent_Sets;
 473
 474    -------------------------
 475    -- Equivalent_Elements --
 476    -------------------------
 477
 478    function Equivalent_Elements (Left, Right : Cursor)
 479      return Boolean is
 480    begin
 481       if Left.Node = 0 then
 482          raise Constraint_Error with
 483            "Left cursor of Equivalent_Elements equals No_Element";
 484       end if;
 485
 486       if Right.Node = 0 then
 487          raise Constraint_Error with
 488            "Right cursor of Equivalent_Elements equals No_Element";
 489       end if;
 490
 491       pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
 492       pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
 493
 494       declare
 495          LN : Node_Type renames Left.Container.Nodes (Left.Node);
 496          RN : Node_Type renames Right.Container.Nodes (Right.Node);
 497
 498       begin
 499          return Equivalent_Elements (LN.Element, RN.Element);
 500       end;
 501    end Equivalent_Elements;
 502
 503    function Equivalent_Elements (Left : Cursor; Right : Element_Type)
 504      return Boolean is
 505    begin
 506       if Left.Node = 0 then
 507          raise Constraint_Error with
 508            "Left cursor of Equivalent_Elements equals No_Element";
 509       end if;
 510
 511       pragma Assert (Vet (Left), "Left cursor in Equivalent_Elements is bad");
 512
 513       declare
 514          LN : Node_Type renames Left.Container.Nodes (Left.Node);
 515       begin
 516          return Equivalent_Elements (LN.Element, Right);
 517       end;
 518    end Equivalent_Elements;
 519
 520    function Equivalent_Elements (Left : Element_Type; Right : Cursor)
 521      return Boolean is
 522    begin
 523       if Right.Node = 0 then
 524          raise Constraint_Error with
 525            "Right cursor of Equivalent_Elements equals No_Element";
 526       end if;
 527
 528       pragma Assert
 529         (Vet (Right),
 530          "Right cursor of Equivalent_Elements is bad");
 531
 532       declare
 533          RN : Node_Type renames Right.Container.Nodes (Right.Node);
 534       begin
 535          return Equivalent_Elements (Left, RN.Element);
 536       end;
 537    end Equivalent_Elements;
 538
 539    ---------------------
 540    -- Equivalent_Keys --
 541    ---------------------
 542
 543    function Equivalent_Keys (Key : Element_Type; Node : Node_Type)
 544      return Boolean is
 545    begin
 546       return Equivalent_Elements (Key, Node.Element);
 547    end Equivalent_Keys;
 548
 549    -------------
 550    -- Exclude --
 551    -------------
 552
 553    procedure Exclude
 554      (Container : in out Set;
 555       Item      : Element_Type)
 556    is
 557       X : Count_Type;
 558    begin
 559       Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
 560       HT_Ops.Free (Container, X);
 561    end Exclude;
 562
 563    ----------
 564    -- Find --
 565    ----------
 566
 567    function Find
 568      (Container : Set;
 569       Item      : Element_Type) return Cursor
 570    is
 571       Node : constant Count_Type := Element_Keys.Find (Container, Item);
 572
 573    begin
 574       if Node = 0 then
 575          return No_Element;
 576       end if;
 577
 578       return Cursor'(Container'Unrestricted_Access, Node);
 579    end Find;
 580
 581    -----------
 582    -- First --
 583    -----------
 584
 585    function First (Container : Set) return Cursor is
 586       Node : constant Count_Type := HT_Ops.First (Container);
 587
 588    begin
 589       if Node = 0 then
 590          return No_Element;
 591       end if;
 592
 593       return Cursor'(Container'Unrestricted_Access, Node);
 594    end First;
 595
 596    -----------------
 597    -- Has_Element --
 598    -----------------
 599
 600    function Has_Element (Position : Cursor) return Boolean is
 601    begin
 602       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 603       return Position.Node /= 0;
 604    end Has_Element;
 605
 606    ---------------
 607    -- Hash_Node --
 608    ---------------
 609
 610    function Hash_Node (Node : Node_Type) return Hash_Type is
 611    begin
 612       return Hash (Node.Element);
 613    end Hash_Node;
 614
 615    -------------
 616    -- Include --
 617    -------------
 618
 619    procedure Include
 620      (Container : in out Set;
 621       New_Item  : Element_Type)
 622    is
 623       Position : Cursor;
 624       Inserted : Boolean;
 625
 626    begin
 627       Insert (Container, New_Item, Position, Inserted);
 628
 629       if not Inserted then
 630          if Container.Lock > 0 then
 631             raise Program_Error with
 632               "attempt to tamper with elements (set is locked)";
 633          end if;
 634
 635          Container.Nodes (Position.Node).Element := New_Item;
 636       end if;
 637    end Include;
 638
 639    ------------
 640    -- Insert --
 641    ------------
 642
 643    procedure Insert
 644      (Container : in out Set;
 645       New_Item  : Element_Type;
 646       Position  : out Cursor;
 647       Inserted  : out Boolean)
 648    is
 649    begin
 650       Insert (Container, New_Item, Position.Node, Inserted);
 651       Position.Container := Container'Unchecked_Access;
 652    end Insert;
 653
 654    procedure Insert
 655      (Container : in out Set;
 656       New_Item  : Element_Type)
 657    is
 658       Position : Cursor;
 659       pragma Unreferenced (Position);
 660
 661       Inserted : Boolean;
 662
 663    begin
 664       Insert (Container, New_Item, Position, Inserted);
 665
 666       if not Inserted then
 667          raise Constraint_Error with
 668            "attempt to insert element already in set";
 669       end if;
 670    end Insert;
 671
 672    procedure Insert
 673      (Container : in out Set;
 674       New_Item  : Element_Type;
 675       Node      : out Count_Type;
 676       Inserted  : out Boolean)
 677    is
 678       procedure Allocate_Set_Element (Node : in out Node_Type);
 679       pragma Inline (Allocate_Set_Element);
 680
 681       function New_Node return Count_Type;
 682       pragma Inline (New_Node);
 683
 684       procedure Local_Insert is
 685         new Element_Keys.Generic_Conditional_Insert (New_Node);
 686
 687       procedure Allocate is
 688          new HT_Ops.Generic_Allocate (Allocate_Set_Element);
 689
 690       ---------------------------
 691       --  Allocate_Set_Element --
 692       ---------------------------
 693
 694       procedure Allocate_Set_Element (Node : in out Node_Type) is
 695       begin
 696          Node.Element := New_Item;
 697       end Allocate_Set_Element;
 698
 699       --------------
 700       -- New_Node --
 701       --------------
 702
 703       function New_Node return Count_Type is
 704          Result : Count_Type;
 705       begin
 706          Allocate (Container, Result);
 707          return Result;
 708       end New_Node;
 709
 710    --  Start of processing for Insert
 711
 712    begin
 713       --  The buckets array length is specified by the user as a discriminant
 714       --  of the container type, so it is possible for the buckets array to
 715       --  have a length of zero. We must check for this case specifically, in
 716       --  order to prevent divide-by-zero errors later, when we compute the
 717       --  buckets array index value for an element, given its hash value.
 718
 719       if Container.Buckets'Length = 0 then
 720          raise Capacity_Error with "No capacity for insertion";
 721       end if;
 722
 723       Local_Insert (Container, New_Item, Node, Inserted);
 724    end Insert;
 725
 726    ------------------
 727    -- Intersection --
 728    ------------------
 729
 730    procedure Intersection
 731      (Target : in out Set;
 732       Source : Set)
 733    is
 734       Tgt_Node : Count_Type;
 735       TN       : Nodes_Type renames Target.Nodes;
 736
 737    begin
 738       if Target'Address = Source'Address then
 739          return;
 740       end if;
 741
 742       if Source.Length = 0 then
 743          HT_Ops.Clear (Target);
 744          return;
 745       end if;
 746
 747       if Target.Busy > 0 then
 748          raise Program_Error with
 749            "attempt to tamper with cursors (set is busy)";
 750       end if;
 751
 752       Tgt_Node := HT_Ops.First (Target);
 753       while Tgt_Node /= 0 loop
 754          if Is_In (Source, TN (Tgt_Node)) then
 755             Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 756
 757          else
 758             declare
 759                X : constant Count_Type := Tgt_Node;
 760             begin
 761                Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 762                HT_Ops.Delete_Node_Sans_Free (Target, X);
 763                HT_Ops.Free (Target, X);
 764             end;
 765          end if;
 766       end loop;
 767    end Intersection;
 768
 769    function Intersection (Left, Right : Set) return Set is
 770       C : Count_Type;
 771
 772    begin
 773       if Left'Address = Right'Address then
 774          return Left;
 775       end if;
 776
 777       C := Count_Type'Min (Left.Length, Right.Length);
 778
 779       if C = 0 then
 780          return Empty_Set;
 781       end if;
 782
 783       return Result : Set (C, To_Prime (C)) do
 784          Iterate_Left : declare
 785             procedure Process (L_Node : Count_Type);
 786
 787             procedure Iterate is
 788                new HT_Ops.Generic_Iteration (Process);
 789
 790             -------------
 791             -- Process --
 792             -------------
 793
 794             procedure Process (L_Node : Count_Type) is
 795                N : Node_Type renames Left.Nodes (L_Node);
 796                X : Count_Type;
 797                B : Boolean;
 798
 799             begin
 800                if Is_In (Right, N) then
 801                   Insert (Result, N.Element, X, B);  -- optimize ???
 802                   pragma Assert (B);
 803                   pragma Assert (X > 0);
 804                end if;
 805             end Process;
 806
 807          --  Start of processing for Iterate_Left
 808
 809          begin
 810             Iterate (Left);
 811          end Iterate_Left;
 812       end return;
 813    end Intersection;
 814
 815    --------------
 816    -- Is_Empty --
 817    --------------
 818
 819    function Is_Empty (Container : Set) return Boolean is
 820    begin
 821       return Container.Length = 0;
 822    end Is_Empty;
 823
 824    -----------
 825    -- Is_In --
 826    -----------
 827
 828    function Is_In (HT : Set; Key : Node_Type) return Boolean is
 829    begin
 830       return Element_Keys.Find (HT, Key.Element) /= 0;
 831    end Is_In;
 832
 833    ---------------
 834    -- Is_Subset --
 835    ---------------
 836
 837    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
 838       Subset_Node : Count_Type;
 839       SN          : Nodes_Type renames Subset.Nodes;
 840
 841    begin
 842       if Subset'Address = Of_Set'Address then
 843          return True;
 844       end if;
 845
 846       if Subset.Length > Of_Set.Length then
 847          return False;
 848       end if;
 849
 850       Subset_Node := HT_Ops.First (Subset);
 851       while Subset_Node /= 0 loop
 852          if not Is_In (Of_Set, SN (Subset_Node)) then
 853             return False;
 854          end if;
 855          Subset_Node := HT_Ops.Next (Subset, Subset_Node);
 856       end loop;
 857
 858       return True;
 859    end Is_Subset;
 860
 861    -------------
 862    -- Iterate --
 863    -------------
 864
 865    procedure Iterate
 866      (Container : Set;
 867       Process   : not null access procedure (Position : Cursor))
 868    is
 869       procedure Process_Node (Node : Count_Type);
 870       pragma Inline (Process_Node);
 871
 872       procedure Iterate is
 873          new HT_Ops.Generic_Iteration (Process_Node);
 874
 875       ------------------
 876       -- Process_Node --
 877       ------------------
 878
 879       procedure Process_Node (Node : Count_Type) is
 880       begin
 881          Process (Cursor'(Container'Unrestricted_Access, Node));
 882       end Process_Node;
 883
 884       B : Natural renames Container'Unrestricted_Access.Busy;
 885
 886    --  Start of processing for Iterate
 887
 888    begin
 889       B := B + 1;
 890
 891       begin
 892          Iterate (Container);
 893       exception
 894          when others =>
 895             B := B - 1;
 896             raise;
 897       end;
 898
 899       B := B - 1;
 900    end Iterate;
 901
 902    ------------
 903    -- Length --
 904    ------------
 905
 906    function Length (Container : Set) return Count_Type is
 907    begin
 908       return Container.Length;
 909    end Length;
 910
 911    ----------
 912    -- Move --
 913    ----------
 914
 915    procedure Move (Target : in out Set; Source : in out Set) is
 916    begin
 917       if Target'Address = Source'Address then
 918          return;
 919       end if;
 920
 921       if Source.Busy > 0 then
 922          raise Program_Error with
 923            "attempt to tamper with cursors (container is busy)";
 924       end if;
 925
 926       Target.Assign (Source);
 927       Source.Clear;
 928    end Move;
 929
 930    ----------
 931    -- Next --
 932    ----------
 933
 934    function Next (Node : Node_Type) return Count_Type is
 935    begin
 936       return Node.Next;
 937    end Next;
 938
 939    function Next (Position : Cursor) return Cursor is
 940    begin
 941       if Position.Node = 0 then
 942          return No_Element;
 943       end if;
 944
 945       pragma Assert (Vet (Position), "bad cursor in Next");
 946
 947       declare
 948          HT   : Set renames Position.Container.all;
 949          Node : constant Count_Type := HT_Ops.Next (HT, Position.Node);
 950
 951       begin
 952          if Node = 0 then
 953             return No_Element;
 954          end if;
 955
 956          return Cursor'(Position.Container, Node);
 957       end;
 958    end Next;
 959
 960    procedure Next (Position : in out Cursor) is
 961    begin
 962       Position := Next (Position);
 963    end Next;
 964
 965    -------------
 966    -- Overlap --
 967    -------------
 968
 969    function Overlap (Left, Right : Set) return Boolean is
 970       Left_Node : Count_Type;
 971
 972    begin
 973       if Right.Length = 0 then
 974          return False;
 975       end if;
 976
 977       if Left'Address = Right'Address then
 978          return True;
 979       end if;
 980
 981       Left_Node := HT_Ops.First (Left);
 982       while Left_Node /= 0 loop
 983          if Is_In (Right, Left.Nodes (Left_Node)) then
 984             return True;
 985          end if;
 986          Left_Node := HT_Ops.Next (Left, Left_Node);
 987       end loop;
 988
 989       return False;
 990    end Overlap;
 991
 992    -------------------
 993    -- Query_Element --
 994    -------------------
 995
 996    procedure Query_Element
 997      (Position : Cursor;
 998       Process  : not null access procedure (Element : Element_Type))
 999    is
1000    begin
1001       if Position.Node = 0 then
1002          raise Constraint_Error with
1003            "Position cursor of Query_Element equals No_Element";
1004       end if;
1005
1006       pragma Assert (Vet (Position), "bad cursor in Query_Element");
1007
1008       declare
1009          S : Set renames Position.Container.all;
1010          B : Natural renames S.Busy;
1011          L : Natural renames S.Lock;
1012
1013       begin
1014          B := B + 1;
1015          L := L + 1;
1016
1017          begin
1018             Process (S.Nodes (Position.Node).Element);
1019          exception
1020             when others =>
1021                L := L - 1;
1022                B := B - 1;
1023                raise;
1024          end;
1025
1026          L := L - 1;
1027          B := B - 1;
1028       end;
1029    end Query_Element;
1030
1031    ----------
1032    -- Read --
1033    ----------
1034
1035    procedure Read
1036      (Stream    : not null access Root_Stream_Type'Class;
1037       Container : out Set)
1038    is
1039       function Read_Node (Stream : not null access Root_Stream_Type'Class)
1040         return Count_Type;
1041
1042       procedure Read_Nodes is
1043          new HT_Ops.Generic_Read (Read_Node);
1044
1045       ---------------
1046       -- Read_Node --
1047       ---------------
1048
1049       function Read_Node (Stream : not null access Root_Stream_Type'Class)
1050         return Count_Type
1051       is
1052          procedure Read_Element (Node : in out Node_Type);
1053          pragma Inline (Read_Element);
1054
1055          procedure Allocate is
1056             new HT_Ops.Generic_Allocate (Read_Element);
1057
1058          procedure Read_Element (Node : in out Node_Type) is
1059          begin
1060             Element_Type'Read (Stream, Node.Element);
1061          end Read_Element;
1062
1063          Node : Count_Type;
1064
1065       --  Start of processing for Read_Node
1066
1067       begin
1068          Allocate (Container, Node);
1069          return Node;
1070       end Read_Node;
1071
1072    --  Start of processing for Read
1073
1074    begin
1075       Read_Nodes (Stream, Container);
1076    end Read;
1077
1078    procedure Read
1079      (Stream : not null access Root_Stream_Type'Class;
1080       Item   : out Cursor)
1081    is
1082    begin
1083       raise Program_Error with "attempt to stream set cursor";
1084    end Read;
1085
1086    -------------
1087    -- Replace --
1088    -------------
1089
1090    procedure Replace
1091      (Container : in out Set;
1092       New_Item  : Element_Type)
1093    is
1094       Node : constant Count_Type :=
1095                Element_Keys.Find (Container, New_Item);
1096
1097    begin
1098       if Node = 0 then
1099          raise Constraint_Error with
1100            "attempt to replace element not in set";
1101       end if;
1102
1103       if Container.Lock > 0 then
1104          raise Program_Error with
1105            "attempt to tamper with elements (set is locked)";
1106       end if;
1107
1108       Container.Nodes (Node).Element := New_Item;
1109    end Replace;
1110
1111    procedure Replace_Element
1112      (Container : in out Set;
1113       Position  : Cursor;
1114       New_Item  : Element_Type)
1115    is
1116    begin
1117       if Position.Node = 0 then
1118          raise Constraint_Error with
1119            "Position cursor equals No_Element";
1120       end if;
1121
1122       if Position.Container /= Container'Unrestricted_Access then
1123          raise Program_Error with
1124            "Position cursor designates wrong set";
1125       end if;
1126
1127       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1128
1129       Replace_Element (Container, Position.Node, New_Item);
1130    end Replace_Element;
1131
1132    ----------------------
1133    -- Reserve_Capacity --
1134    ----------------------
1135
1136    procedure Reserve_Capacity
1137      (Container : in out Set;
1138       Capacity  : Count_Type)
1139    is
1140    begin
1141       if Capacity > Container.Capacity then
1142          raise Capacity_Error with "requested capacity is too large";
1143       end if;
1144    end Reserve_Capacity;
1145
1146    ------------------
1147    --  Set_Element --
1148    ------------------
1149
1150    procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is
1151    begin
1152       Node.Element := Item;
1153    end Set_Element;
1154
1155    --------------
1156    -- Set_Next --
1157    --------------
1158
1159    procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
1160    begin
1161       Node.Next := Next;
1162    end Set_Next;
1163
1164    --------------------------
1165    -- Symmetric_Difference --
1166    --------------------------
1167
1168    procedure Symmetric_Difference
1169      (Target : in out Set;
1170       Source : Set)
1171    is
1172       procedure Process (Source_Node : Count_Type);
1173       pragma Inline (Process);
1174
1175       procedure Iterate is
1176          new HT_Ops.Generic_Iteration (Process);
1177
1178       -------------
1179       -- Process --
1180       -------------
1181
1182       procedure Process (Source_Node : Count_Type) is
1183          N : Node_Type renames Source.Nodes (Source_Node);
1184          X : Count_Type;
1185          B : Boolean;
1186
1187       begin
1188          if Is_In (Target, N) then
1189             Delete (Target, N.Element);
1190          else
1191             Insert (Target, N.Element, X, B);
1192             pragma Assert (B);
1193          end if;
1194       end Process;
1195
1196    --  Start of processing for Symmetric_Difference
1197
1198    begin
1199       if Target'Address = Source'Address then
1200          HT_Ops.Clear (Target);
1201          return;
1202       end if;
1203
1204       if Target.Length = 0 then
1205          Assign (Target => Target, Source => Source);
1206          return;
1207       end if;
1208
1209       if Target.Busy > 0 then
1210          raise Program_Error with
1211            "attempt to tamper with cursors (set is busy)";
1212       end if;
1213
1214       Iterate (Source);
1215    end Symmetric_Difference;
1216
1217    function Symmetric_Difference (Left, Right : Set) return Set is
1218       C : Count_Type;
1219
1220    begin
1221       if Left'Address = Right'Address then
1222          return Empty_Set;
1223       end if;
1224
1225       if Right.Length = 0 then
1226          return Left;
1227       end if;
1228
1229       if Left.Length = 0 then
1230          return Right;
1231       end if;
1232
1233       C := Left.Length + Right.Length;
1234
1235       return Result : Set (C, To_Prime (C)) do
1236          Iterate_Left : declare
1237             procedure Process (L_Node : Count_Type);
1238
1239             procedure Iterate is
1240                new HT_Ops.Generic_Iteration (Process);
1241
1242             -------------
1243             -- Process --
1244             -------------
1245
1246             procedure Process (L_Node : Count_Type) is
1247                N : Node_Type renames Left.Nodes (L_Node);
1248                X : Count_Type;
1249                B : Boolean;
1250
1251             begin
1252                if not Is_In (Right, N) then
1253                   Insert (Result, N.Element, X, B);
1254                   pragma Assert (B);
1255                end if;
1256             end Process;
1257
1258          --  Start of processing for Iterate_Left
1259
1260          begin
1261             Iterate (Left);
1262          end Iterate_Left;
1263
1264          Iterate_Right : declare
1265             procedure Process (R_Node : Count_Type);
1266
1267             procedure Iterate is
1268                new HT_Ops.Generic_Iteration (Process);
1269
1270             -------------
1271             -- Process --
1272             -------------
1273
1274             procedure Process (R_Node : Count_Type) is
1275                N : Node_Type renames Right.Nodes (R_Node);
1276                X : Count_Type;
1277                B : Boolean;
1278
1279             begin
1280                if not Is_In (Left, N) then
1281                   Insert (Result, N.Element, X, B);
1282                   pragma Assert (B);
1283                end if;
1284             end Process;
1285
1286          --  Start of processing for Iterate_Right
1287
1288          begin
1289             Iterate (Right);
1290          end Iterate_Right;
1291       end return;
1292    end Symmetric_Difference;
1293
1294    ------------
1295    -- To_Set --
1296    ------------
1297
1298    function To_Set (New_Item : Element_Type) return Set is
1299       X : Count_Type;
1300       B : Boolean;
1301
1302    begin
1303       return Result : Set (1, 1) do
1304          Insert (Result, New_Item, X, B);
1305          pragma Assert (B);
1306       end return;
1307    end To_Set;
1308
1309    -----------
1310    -- Union --
1311    -----------
1312
1313    procedure Union
1314      (Target : in out Set;
1315       Source : Set)
1316    is
1317       procedure Process (Src_Node : Count_Type);
1318
1319       procedure Iterate is
1320          new HT_Ops.Generic_Iteration (Process);
1321
1322       -------------
1323       -- Process --
1324       -------------
1325
1326       procedure Process (Src_Node : Count_Type) is
1327          N : Node_Type renames Source.Nodes (Src_Node);
1328          X : Count_Type;
1329          B : Boolean;
1330
1331       begin
1332          Insert (Target, N.Element, X, B);
1333       end Process;
1334
1335    --  Start of processing for Union
1336
1337    begin
1338       if Target'Address = Source'Address then
1339          return;
1340       end if;
1341
1342       if Target.Busy > 0 then
1343          raise Program_Error with
1344            "attempt to tamper with cursors (set is busy)";
1345       end if;
1346
1347       --  ???
1348       --  declare
1349       --     N : constant Count_Type := Target.Length + Source.Length;
1350       --  begin
1351       --     if N > HT_Ops.Capacity (Target.HT) then
1352       --        HT_Ops.Reserve_Capacity (Target.HT, N);
1353       --     end if;
1354       --  end;
1355
1356       Iterate (Source);
1357    end Union;
1358
1359    function Union (Left, Right : Set) return Set is
1360       C : Count_Type;
1361
1362    begin
1363       if Left'Address = Right'Address then
1364          return Left;
1365       end if;
1366
1367       if Right.Length = 0 then
1368          return Left;
1369       end if;
1370
1371       if Left.Length = 0 then
1372          return Right;
1373       end if;
1374
1375       C := Left.Length + Right.Length;
1376
1377       return Result : Set (C, To_Prime (C)) do
1378          Assign (Target => Result, Source => Left);
1379          Union (Target => Result, Source => Right);
1380       end return;
1381    end Union;
1382
1383    ---------
1384    -- Vet --
1385    ---------
1386
1387    function Vet (Position : Cursor) return Boolean is
1388    begin
1389       if Position.Node = 0 then
1390          return Position.Container = null;
1391       end if;
1392
1393       if Position.Container = null then
1394          return False;
1395       end if;
1396
1397       declare
1398          S : Set renames Position.Container.all;
1399          N : Nodes_Type renames S.Nodes;
1400          X : Count_Type;
1401
1402       begin
1403          if S.Length = 0 then
1404             return False;
1405          end if;
1406
1407          if Position.Node > N'Last then
1408             return False;
1409          end if;
1410
1411          if N (Position.Node).Next = Position.Node then
1412             return False;
1413          end if;
1414
1415          X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element));
1416
1417          for J in 1 .. S.Length loop
1418             if X = Position.Node then
1419                return True;
1420             end if;
1421
1422             if X = 0 then
1423                return False;
1424             end if;
1425
1426             if X = N (X).Next then  --  to prevent unnecessary looping
1427                return False;
1428             end if;
1429
1430             X := N (X).Next;
1431          end loop;
1432
1433          return False;
1434       end;
1435    end Vet;
1436
1437    -----------
1438    -- Write --
1439    -----------
1440
1441    procedure Write
1442      (Stream    : not null access Root_Stream_Type'Class;
1443       Container : Set)
1444    is
1445       procedure Write_Node
1446         (Stream : not null access Root_Stream_Type'Class;
1447          Node   : Node_Type);
1448       pragma Inline (Write_Node);
1449
1450       procedure Write_Nodes is
1451          new HT_Ops.Generic_Write (Write_Node);
1452
1453       ----------------
1454       -- Write_Node --
1455       ----------------
1456
1457       procedure Write_Node
1458         (Stream : not null access Root_Stream_Type'Class;
1459          Node   : Node_Type)
1460       is
1461       begin
1462          Element_Type'Write (Stream, Node.Element);
1463       end Write_Node;
1464
1465    --  Start of processing for Write
1466
1467    begin
1468       Write_Nodes (Stream, Container);
1469    end Write;
1470
1471    procedure Write
1472      (Stream : not null access Root_Stream_Type'Class;
1473       Item   : Cursor)
1474    is
1475    begin
1476       raise Program_Error with "attempt to stream set cursor";
1477    end Write;
1478
1479    package body Generic_Keys is
1480
1481       -----------------------
1482       -- Local Subprograms --
1483       -----------------------
1484
1485       function Equivalent_Key_Node
1486         (Key  : Key_Type;
1487          Node : Node_Type) return Boolean;
1488       pragma Inline (Equivalent_Key_Node);
1489
1490       --------------------------
1491       -- Local Instantiations --
1492       --------------------------
1493
1494       package Key_Keys is
1495          new Hash_Tables.Generic_Bounded_Keys
1496           (HT_Types  => HT_Types,
1497            Next      => Next,
1498            Set_Next  => Set_Next,
1499            Key_Type  => Key_Type,
1500            Hash      => Hash,
1501            Equivalent_Keys => Equivalent_Key_Node);
1502
1503       --------------
1504       -- Contains --
1505       --------------
1506
1507       function Contains
1508         (Container : Set;
1509          Key       : Key_Type) return Boolean
1510       is
1511       begin
1512          return Find (Container, Key) /= No_Element;
1513       end Contains;
1514
1515       ------------
1516       -- Delete --
1517       ------------
1518
1519       procedure Delete
1520         (Container : in out Set;
1521          Key       : Key_Type)
1522       is
1523          X : Count_Type;
1524
1525       begin
1526          Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1527
1528          if X = 0 then
1529             raise Constraint_Error with "attempt to delete key not in set";
1530          end if;
1531
1532          HT_Ops.Free (Container, X);
1533       end Delete;
1534
1535       -------------
1536       -- Element --
1537       -------------
1538
1539       function Element
1540         (Container : Set;
1541          Key       : Key_Type) return Element_Type
1542       is
1543          Node : constant Count_Type := Key_Keys.Find (Container, Key);
1544
1545       begin
1546          if Node = 0 then
1547             raise Constraint_Error with "key not in map";
1548          end if;
1549
1550          return Container.Nodes (Node).Element;
1551       end Element;
1552
1553       -------------------------
1554       -- Equivalent_Key_Node --
1555       -------------------------
1556
1557       function Equivalent_Key_Node
1558         (Key  : Key_Type;
1559          Node : Node_Type) return Boolean
1560       is
1561       begin
1562          return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
1563       end Equivalent_Key_Node;
1564
1565       -------------
1566       -- Exclude --
1567       -------------
1568
1569       procedure Exclude
1570         (Container : in out Set;
1571          Key       : Key_Type)
1572       is
1573          X : Count_Type;
1574       begin
1575          Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1576          HT_Ops.Free (Container, X);
1577       end Exclude;
1578
1579       ----------
1580       -- Find --
1581       ----------
1582
1583       function Find
1584         (Container : Set;
1585          Key       : Key_Type) return Cursor
1586       is
1587          Node : constant Count_Type :=
1588                   Key_Keys.Find (Container, Key);
1589
1590       begin
1591          if Node = 0 then
1592             return No_Element;
1593          end if;
1594
1595          return Cursor'(Container'Unrestricted_Access, Node);
1596       end Find;
1597
1598       ---------
1599       -- Key --
1600       ---------
1601
1602       function Key (Position : Cursor) return Key_Type is
1603       begin
1604          if Position.Node = 0 then
1605             raise Constraint_Error with
1606               "Position cursor equals No_Element";
1607          end if;
1608
1609          pragma Assert (Vet (Position), "bad cursor in function Key");
1610
1611          return Key (Position.Container.Nodes (Position.Node).Element);
1612       end Key;
1613
1614       -------------
1615       -- Replace --
1616       -------------
1617
1618       procedure Replace
1619         (Container : in out Set;
1620          Key       : Key_Type;
1621          New_Item  : Element_Type)
1622       is
1623          Node : constant Count_Type :=
1624                   Key_Keys.Find (Container, Key);
1625
1626       begin
1627          if Node = 0 then
1628             raise Constraint_Error with
1629               "attempt to replace key not in set";
1630          end if;
1631
1632          Replace_Element (Container, Node, New_Item);
1633       end Replace;
1634
1635       -----------------------------------
1636       -- Update_Element_Preserving_Key --
1637       -----------------------------------
1638
1639       procedure Update_Element_Preserving_Key
1640         (Container : in out Set;
1641          Position  : Cursor;
1642          Process   : not null access
1643                        procedure (Element : in out Element_Type))
1644       is
1645          Indx : Hash_Type;
1646          N    : Nodes_Type renames Container.Nodes;
1647
1648       begin
1649          if Position.Node = 0 then
1650             raise Constraint_Error with
1651               "Position cursor equals No_Element";
1652          end if;
1653
1654          if Position.Container /= Container'Unrestricted_Access then
1655             raise Program_Error with
1656               "Position cursor designates wrong set";
1657          end if;
1658
1659          --  ???
1660          --  if HT.Buckets = null
1661          --    or else HT.Buckets'Length = 0
1662          --    or else HT.Length = 0
1663          --    or else Position.Node.Next = Position.Node
1664          --  then
1665          --     raise Program_Error with
1666          --        "Position cursor is bad (set is empty)";
1667          --  end if;
1668
1669          pragma Assert
1670            (Vet (Position),
1671             "bad cursor in Update_Element_Preserving_Key");
1672
1673          --  Record bucket now, in case key is changed.
1674          Indx := HT_Ops.Index (Container.Buckets, N (Position.Node));
1675
1676          declare
1677             E : Element_Type renames N (Position.Node).Element;
1678             K : constant Key_Type := Key (E);
1679
1680             B : Natural renames Container.Busy;
1681             L : Natural renames Container.Lock;
1682
1683          begin
1684             B := B + 1;
1685             L := L + 1;
1686
1687             begin
1688                Process (E);
1689             exception
1690                when others =>
1691                   L := L - 1;
1692                   B := B - 1;
1693                   raise;
1694             end;
1695
1696             L := L - 1;
1697             B := B - 1;
1698
1699             if Equivalent_Keys (K, Key (E)) then
1700                pragma Assert (Hash (K) = Hash (E));
1701                return;
1702             end if;
1703          end;
1704
1705          --  Key was modified, so remove this node from set.
1706
1707          if Container.Buckets (Indx) = Position.Node then
1708             Container.Buckets (Indx) := N (Position.Node).Next;
1709
1710          else
1711             declare
1712                Prev : Count_Type := Container.Buckets (Indx);
1713
1714             begin
1715                while N (Prev).Next /= Position.Node loop
1716                   Prev := N (Prev).Next;
1717
1718                   if Prev = 0 then
1719                      raise Program_Error with
1720                        "Position cursor is bad (node not found)";
1721                   end if;
1722                end loop;
1723
1724                N (Prev).Next := N (Position.Node).Next;
1725             end;
1726          end if;
1727
1728          Container.Length := Container.Length - 1;
1729          HT_Ops.Free (Container, Position.Node);
1730
1731          raise Program_Error with "key was modified";
1732       end Update_Element_Preserving_Key;
1733
1734    end Generic_Keys;
1735
1736 end Ada.Containers.Bounded_Hashed_Sets;