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-2012, 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 := Element_Keys.Find (Container, New_Item);
1184
1185    begin
1186       if Node = 0 then
1187          raise Constraint_Error with
1188            "attempt to replace element not in set";
1189       end if;
1190
1191       if Container.Lock > 0 then
1192          raise Program_Error with
1193            "attempt to tamper with elements (set is locked)";
1194       end if;
1195
1196       Container.Nodes (Node).Element := New_Item;
1197    end Replace;
1198
1199    procedure Replace_Element
1200      (Container : in out Set;
1201       Position  : Cursor;
1202       New_Item  : Element_Type)
1203    is
1204    begin
1205       if Position.Node = 0 then
1206          raise Constraint_Error with
1207            "Position cursor equals No_Element";
1208       end if;
1209
1210       if Position.Container /= Container'Unrestricted_Access then
1211          raise Program_Error with
1212            "Position cursor designates wrong set";
1213       end if;
1214
1215       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1216
1217       Replace_Element (Container, Position.Node, New_Item);
1218    end Replace_Element;
1219
1220    ----------------------
1221    -- Reserve_Capacity --
1222    ----------------------
1223
1224    procedure Reserve_Capacity
1225      (Container : in out Set;
1226       Capacity  : Count_Type)
1227    is
1228    begin
1229       if Capacity > Container.Capacity then
1230          raise Capacity_Error with "requested capacity is too large";
1231       end if;
1232    end Reserve_Capacity;
1233
1234    ------------------
1235    --  Set_Element --
1236    ------------------
1237
1238    procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is
1239    begin
1240       Node.Element := Item;
1241    end Set_Element;
1242
1243    --------------
1244    -- Set_Next --
1245    --------------
1246
1247    procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
1248    begin
1249       Node.Next := Next;
1250    end Set_Next;
1251
1252    --------------------------
1253    -- Symmetric_Difference --
1254    --------------------------
1255
1256    procedure Symmetric_Difference
1257      (Target : in out Set;
1258       Source : Set)
1259    is
1260       procedure Process (Source_Node : Count_Type);
1261       pragma Inline (Process);
1262
1263       procedure Iterate is
1264          new HT_Ops.Generic_Iteration (Process);
1265
1266       -------------
1267       -- Process --
1268       -------------
1269
1270       procedure Process (Source_Node : Count_Type) is
1271          N : Node_Type renames Source.Nodes (Source_Node);
1272          X : Count_Type;
1273          B : Boolean;
1274
1275       begin
1276          if Is_In (Target, N) then
1277             Delete (Target, N.Element);
1278          else
1279             Insert (Target, N.Element, X, B);
1280             pragma Assert (B);
1281          end if;
1282       end Process;
1283
1284    --  Start of processing for Symmetric_Difference
1285
1286    begin
1287       if Target'Address = Source'Address then
1288          HT_Ops.Clear (Target);
1289          return;
1290       end if;
1291
1292       if Target.Length = 0 then
1293          Assign (Target => Target, Source => Source);
1294          return;
1295       end if;
1296
1297       if Target.Busy > 0 then
1298          raise Program_Error with
1299            "attempt to tamper with cursors (set is busy)";
1300       end if;
1301
1302       Iterate (Source);
1303    end Symmetric_Difference;
1304
1305    function Symmetric_Difference (Left, Right : Set) return Set is
1306       C : Count_Type;
1307
1308    begin
1309       if Left'Address = Right'Address then
1310          return Empty_Set;
1311       end if;
1312
1313       if Right.Length = 0 then
1314          return Left;
1315       end if;
1316
1317       if Left.Length = 0 then
1318          return Right;
1319       end if;
1320
1321       C := Left.Length + Right.Length;
1322
1323       return Result : Set (C, To_Prime (C)) do
1324          Iterate_Left : declare
1325             procedure Process (L_Node : Count_Type);
1326
1327             procedure Iterate is
1328                new HT_Ops.Generic_Iteration (Process);
1329
1330             -------------
1331             -- Process --
1332             -------------
1333
1334             procedure Process (L_Node : Count_Type) is
1335                N : Node_Type renames Left.Nodes (L_Node);
1336                X : Count_Type;
1337                B : Boolean;
1338             begin
1339                if not Is_In (Right, N) then
1340                   Insert (Result, N.Element, X, B);
1341                   pragma Assert (B);
1342                end if;
1343             end Process;
1344
1345          --  Start of processing for Iterate_Left
1346
1347          begin
1348             Iterate (Left);
1349          end Iterate_Left;
1350
1351          Iterate_Right : declare
1352             procedure Process (R_Node : Count_Type);
1353
1354             procedure Iterate is
1355                new HT_Ops.Generic_Iteration (Process);
1356
1357             -------------
1358             -- Process --
1359             -------------
1360
1361             procedure Process (R_Node : Count_Type) is
1362                N : Node_Type renames Right.Nodes (R_Node);
1363                X : Count_Type;
1364                B : Boolean;
1365             begin
1366                if not Is_In (Left, N) then
1367                   Insert (Result, N.Element, X, B);
1368                   pragma Assert (B);
1369                end if;
1370             end Process;
1371
1372          --  Start of processing for Iterate_Right
1373
1374          begin
1375             Iterate (Right);
1376          end Iterate_Right;
1377       end return;
1378    end Symmetric_Difference;
1379
1380    ------------
1381    -- To_Set --
1382    ------------
1383
1384    function To_Set (New_Item : Element_Type) return Set is
1385       X : Count_Type;
1386       B : Boolean;
1387    begin
1388       return Result : Set (1, 1) do
1389          Insert (Result, New_Item, X, B);
1390          pragma Assert (B);
1391       end return;
1392    end To_Set;
1393
1394    -----------
1395    -- Union --
1396    -----------
1397
1398    procedure Union
1399      (Target : in out Set;
1400       Source : Set)
1401    is
1402       procedure Process (Src_Node : Count_Type);
1403
1404       procedure Iterate is
1405          new HT_Ops.Generic_Iteration (Process);
1406
1407       -------------
1408       -- Process --
1409       -------------
1410
1411       procedure Process (Src_Node : Count_Type) is
1412          N : Node_Type renames Source.Nodes (Src_Node);
1413          X : Count_Type;
1414          B : Boolean;
1415       begin
1416          Insert (Target, N.Element, X, B);
1417       end Process;
1418
1419    --  Start of processing for Union
1420
1421    begin
1422       if Target'Address = Source'Address then
1423          return;
1424       end if;
1425
1426       if Target.Busy > 0 then
1427          raise Program_Error with
1428            "attempt to tamper with cursors (set is busy)";
1429       end if;
1430
1431       --  ??? why is this code commented out ???
1432       --  declare
1433       --     N : constant Count_Type := Target.Length + Source.Length;
1434       --  begin
1435       --     if N > HT_Ops.Capacity (Target.HT) then
1436       --        HT_Ops.Reserve_Capacity (Target.HT, N);
1437       --     end if;
1438       --  end;
1439
1440       Iterate (Source);
1441    end Union;
1442
1443    function Union (Left, Right : Set) return Set is
1444       C : Count_Type;
1445
1446    begin
1447       if Left'Address = Right'Address then
1448          return Left;
1449       end if;
1450
1451       if Right.Length = 0 then
1452          return Left;
1453       end if;
1454
1455       if Left.Length = 0 then
1456          return Right;
1457       end if;
1458
1459       C := Left.Length + Right.Length;
1460
1461       return Result : Set (C, To_Prime (C)) do
1462          Assign (Target => Result, Source => Left);
1463          Union (Target => Result, Source => Right);
1464       end return;
1465    end Union;
1466
1467    ---------
1468    -- Vet --
1469    ---------
1470
1471    function Vet (Position : Cursor) return Boolean is
1472    begin
1473       if Position.Node = 0 then
1474          return Position.Container = null;
1475       end if;
1476
1477       if Position.Container = null then
1478          return False;
1479       end if;
1480
1481       declare
1482          S : Set renames Position.Container.all;
1483          N : Nodes_Type renames S.Nodes;
1484          X : Count_Type;
1485
1486       begin
1487          if S.Length = 0 then
1488             return False;
1489          end if;
1490
1491          if Position.Node > N'Last then
1492             return False;
1493          end if;
1494
1495          if N (Position.Node).Next = Position.Node then
1496             return False;
1497          end if;
1498
1499          X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element));
1500
1501          for J in 1 .. S.Length loop
1502             if X = Position.Node then
1503                return True;
1504             end if;
1505
1506             if X = 0 then
1507                return False;
1508             end if;
1509
1510             if X = N (X).Next then  --  to prevent unnecessary looping
1511                return False;
1512             end if;
1513
1514             X := N (X).Next;
1515          end loop;
1516
1517          return False;
1518       end;
1519    end Vet;
1520
1521    -----------
1522    -- Write --
1523    -----------
1524
1525    procedure Write
1526      (Stream    : not null access Root_Stream_Type'Class;
1527       Container : Set)
1528    is
1529       procedure Write_Node
1530         (Stream : not null access Root_Stream_Type'Class;
1531          Node   : Node_Type);
1532       pragma Inline (Write_Node);
1533
1534       procedure Write_Nodes is
1535          new HT_Ops.Generic_Write (Write_Node);
1536
1537       ----------------
1538       -- Write_Node --
1539       ----------------
1540
1541       procedure Write_Node
1542         (Stream : not null access Root_Stream_Type'Class;
1543          Node   : Node_Type)
1544       is
1545       begin
1546          Element_Type'Write (Stream, Node.Element);
1547       end Write_Node;
1548
1549    --  Start of processing for Write
1550
1551    begin
1552       Write_Nodes (Stream, Container);
1553    end Write;
1554
1555    procedure Write
1556      (Stream : not null access Root_Stream_Type'Class;
1557       Item   : Cursor)
1558    is
1559    begin
1560       raise Program_Error with "attempt to stream set cursor";
1561    end Write;
1562
1563    procedure Write
1564      (Stream : not null access Root_Stream_Type'Class;
1565       Item   : Constant_Reference_Type)
1566    is
1567    begin
1568       raise Program_Error with "attempt to stream reference";
1569    end Write;
1570
1571    package body Generic_Keys is
1572
1573       -----------------------
1574       -- Local Subprograms --
1575       -----------------------
1576
1577       function Equivalent_Key_Node
1578         (Key  : Key_Type;
1579          Node : Node_Type) return Boolean;
1580       pragma Inline (Equivalent_Key_Node);
1581
1582       --------------------------
1583       -- Local Instantiations --
1584       --------------------------
1585
1586       package Key_Keys is
1587          new Hash_Tables.Generic_Bounded_Keys
1588           (HT_Types  => HT_Types,
1589            Next      => Next,
1590            Set_Next  => Set_Next,
1591            Key_Type  => Key_Type,
1592            Hash      => Hash,
1593            Equivalent_Keys => Equivalent_Key_Node);
1594
1595       ------------------------
1596       -- Constant_Reference --
1597       ------------------------
1598
1599       function Constant_Reference
1600         (Container : aliased Set;
1601          Key       : Key_Type) return Constant_Reference_Type
1602       is
1603          Node : constant Count_Type := Key_Keys.Find (Container, Key);
1604
1605       begin
1606          if Node = 0 then
1607             raise Constraint_Error with "key not in set";
1608          end if;
1609
1610          declare
1611             N : Node_Type renames Container.Nodes (Node);
1612          begin
1613             return (Element => N.Element'Access);
1614          end;
1615       end Constant_Reference;
1616
1617       --------------
1618       -- Contains --
1619       --------------
1620
1621       function Contains
1622         (Container : Set;
1623          Key       : Key_Type) return Boolean
1624       is
1625       begin
1626          return Find (Container, Key) /= No_Element;
1627       end Contains;
1628
1629       ------------
1630       -- Delete --
1631       ------------
1632
1633       procedure Delete
1634         (Container : in out Set;
1635          Key       : Key_Type)
1636       is
1637          X : Count_Type;
1638
1639       begin
1640          Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1641
1642          if X = 0 then
1643             raise Constraint_Error with "attempt to delete key not in set";
1644          end if;
1645
1646          HT_Ops.Free (Container, X);
1647       end Delete;
1648
1649       -------------
1650       -- Element --
1651       -------------
1652
1653       function Element
1654         (Container : Set;
1655          Key       : Key_Type) return Element_Type
1656       is
1657          Node : constant Count_Type := Key_Keys.Find (Container, Key);
1658
1659       begin
1660          if Node = 0 then
1661             raise Constraint_Error with "key not in map";  --  ??? "set"
1662          end if;
1663
1664          return Container.Nodes (Node).Element;
1665       end Element;
1666
1667       -------------------------
1668       -- Equivalent_Key_Node --
1669       -------------------------
1670
1671       function Equivalent_Key_Node
1672         (Key  : Key_Type;
1673          Node : Node_Type) return Boolean
1674       is
1675       begin
1676          return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
1677       end Equivalent_Key_Node;
1678
1679       -------------
1680       -- Exclude --
1681       -------------
1682
1683       procedure Exclude
1684         (Container : in out Set;
1685          Key       : Key_Type)
1686       is
1687          X : Count_Type;
1688       begin
1689          Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1690          HT_Ops.Free (Container, X);
1691       end Exclude;
1692
1693       ----------
1694       -- Find --
1695       ----------
1696
1697       function Find
1698         (Container : Set;
1699          Key       : Key_Type) return Cursor
1700       is
1701          Node : constant Count_Type := Key_Keys.Find (Container, Key);
1702       begin
1703          return (if Node = 0 then No_Element
1704                  else Cursor'(Container'Unrestricted_Access, Node));
1705       end Find;
1706
1707       ---------
1708       -- Key --
1709       ---------
1710
1711       function Key (Position : Cursor) return Key_Type is
1712       begin
1713          if Position.Node = 0 then
1714             raise Constraint_Error with
1715               "Position cursor equals No_Element";
1716          end if;
1717
1718          pragma Assert (Vet (Position), "bad cursor in function Key");
1719          return Key (Position.Container.Nodes (Position.Node).Element);
1720       end Key;
1721
1722       ----------
1723       -- Read --
1724       ----------
1725
1726       procedure  Read
1727         (Stream : not null access Root_Stream_Type'Class;
1728          Item   : out Reference_Type)
1729       is
1730       begin
1731          raise Program_Error with "attempt to stream reference";
1732       end Read;
1733
1734       ------------------------------
1735       -- Reference_Preserving_Key --
1736       ------------------------------
1737
1738       function Reference_Preserving_Key
1739         (Container : aliased in out Set;
1740          Position  : Cursor) return Reference_Type
1741       is
1742       begin
1743          if Position.Container = null then
1744             raise Constraint_Error with "Position cursor has no element";
1745          end if;
1746
1747          if Position.Container /= Container'Unrestricted_Access then
1748             raise Program_Error with
1749               "Position cursor designates wrong container";
1750          end if;
1751
1752          pragma Assert
1753            (Vet (Position),
1754             "bad cursor in function Reference_Preserving_Key");
1755
1756          --  Some form of finalization will be required in order to actually
1757          --  check that the key-part of the element designated by Position has
1758          --  not changed.  ???
1759
1760          declare
1761             N : Node_Type renames Container.Nodes (Position.Node);
1762          begin
1763             return (Element => N.Element'Access);
1764          end;
1765       end Reference_Preserving_Key;
1766
1767       function Reference_Preserving_Key
1768         (Container : aliased in out Set;
1769          Key       : Key_Type) return Reference_Type
1770       is
1771          Node : constant Count_Type := Key_Keys.Find (Container, Key);
1772
1773       begin
1774          if Node = 0 then
1775             raise Constraint_Error with "key not in set";
1776          end if;
1777
1778          declare
1779             N : Node_Type renames Container.Nodes (Node);
1780          begin
1781             return (Element => N.Element'Access);
1782          end;
1783       end Reference_Preserving_Key;
1784
1785       -------------
1786       -- Replace --
1787       -------------
1788
1789       procedure Replace
1790         (Container : in out Set;
1791          Key       : Key_Type;
1792          New_Item  : Element_Type)
1793       is
1794          Node : constant Count_Type := Key_Keys.Find (Container, Key);
1795
1796       begin
1797          if Node = 0 then
1798             raise Constraint_Error with
1799               "attempt to replace key not in set";
1800          end if;
1801
1802          Replace_Element (Container, Node, New_Item);
1803       end Replace;
1804
1805       -----------------------------------
1806       -- Update_Element_Preserving_Key --
1807       -----------------------------------
1808
1809       procedure Update_Element_Preserving_Key
1810         (Container : in out Set;
1811          Position  : Cursor;
1812          Process   : not null access
1813                        procedure (Element : in out Element_Type))
1814       is
1815          Indx : Hash_Type;
1816          N    : Nodes_Type renames Container.Nodes;
1817
1818       begin
1819          if Position.Node = 0 then
1820             raise Constraint_Error with
1821               "Position cursor equals No_Element";
1822          end if;
1823
1824          if Position.Container /= Container'Unrestricted_Access then
1825             raise Program_Error with
1826               "Position cursor designates wrong set";
1827          end if;
1828
1829          --  ??? why is this code commented out ???
1830          --  if HT.Buckets = null
1831          --    or else HT.Buckets'Length = 0
1832          --    or else HT.Length = 0
1833          --    or else Position.Node.Next = Position.Node
1834          --  then
1835          --     raise Program_Error with
1836          --        "Position cursor is bad (set is empty)";
1837          --  end if;
1838
1839          pragma Assert
1840            (Vet (Position),
1841             "bad cursor in Update_Element_Preserving_Key");
1842
1843          --  Record bucket now, in case key is changed
1844
1845          Indx := HT_Ops.Index (Container.Buckets, N (Position.Node));
1846
1847          declare
1848             E : Element_Type renames N (Position.Node).Element;
1849             K : constant Key_Type := Key (E);
1850
1851             B : Natural renames Container.Busy;
1852             L : Natural renames Container.Lock;
1853
1854          begin
1855             B := B + 1;
1856             L := L + 1;
1857
1858             begin
1859                Process (E);
1860             exception
1861                when others =>
1862                   L := L - 1;
1863                   B := B - 1;
1864                   raise;
1865             end;
1866
1867             L := L - 1;
1868             B := B - 1;
1869
1870             if Equivalent_Keys (K, Key (E)) then
1871                pragma Assert (Hash (K) = Hash (E));
1872                return;
1873             end if;
1874          end;
1875
1876          --  Key was modified, so remove this node from set.
1877
1878          if Container.Buckets (Indx) = Position.Node then
1879             Container.Buckets (Indx) := N (Position.Node).Next;
1880
1881          else
1882             declare
1883                Prev : Count_Type := Container.Buckets (Indx);
1884
1885             begin
1886                while N (Prev).Next /= Position.Node loop
1887                   Prev := N (Prev).Next;
1888
1889                   if Prev = 0 then
1890                      raise Program_Error with
1891                        "Position cursor is bad (node not found)";
1892                   end if;
1893                end loop;
1894
1895                N (Prev).Next := N (Position.Node).Next;
1896             end;
1897          end if;
1898
1899          Container.Length := Container.Length - 1;
1900          HT_Ops.Free (Container, Position.Node);
1901
1902          raise Program_Error with "key was modified";
1903       end Update_Element_Preserving_Key;
1904
1905       -----------
1906       -- Write --
1907       -----------
1908
1909       procedure Write
1910         (Stream : not null access Root_Stream_Type'Class;
1911          Item   : Reference_Type)
1912       is
1913       begin
1914          raise Program_Error with "attempt to stream reference";
1915       end Write;
1916
1917    end Generic_Keys;
1918
1919 end Ada.Containers.Bounded_Hashed_Sets;