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