gcc/ada/a-cbhase.adb

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