gcc/ada/a-cbhase.adb

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