gcc/ada/a-cohase.adb

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