gcc/ada/a-cohase.adb

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