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