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-2006, 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 : 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 : 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 := new Buckets_Type (0 .. Size - 1);
 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       Inserted : Boolean;
 649
 650    begin
 651       Insert (Container, New_Item, Position, Inserted);
 652
 653       if not Inserted then
 654          raise Constraint_Error with
 655            "attempt to insert element already in set";
 656       end if;
 657    end Insert;
 658
 659    procedure Insert
 660      (HT       : in out Hash_Table_Type;
 661       New_Item : Element_Type;
 662       Node     : out Node_Access;
 663       Inserted : out Boolean)
 664    is
 665       function New_Node (Next : Node_Access) return Node_Access;
 666       pragma Inline (New_Node);
 667
 668       procedure Local_Insert is
 669         new Element_Keys.Generic_Conditional_Insert (New_Node);
 670
 671       --------------
 672       -- New_Node --
 673       --------------
 674
 675       function New_Node (Next : Node_Access) return Node_Access is
 676       begin
 677          return new Node_Type'(New_Item, Next);
 678       end New_Node;
 679
 680    --  Start of processing for Insert
 681
 682    begin
 683       if HT_Ops.Capacity (HT) = 0 then
 684          HT_Ops.Reserve_Capacity (HT, 1);
 685       end if;
 686
 687       Local_Insert (HT, New_Item, Node, Inserted);
 688
 689       if Inserted
 690         and then HT.Length > HT_Ops.Capacity (HT)
 691       then
 692          HT_Ops.Reserve_Capacity (HT, HT.Length);
 693       end if;
 694    end Insert;
 695
 696    ------------------
 697    -- Intersection --
 698    ------------------
 699
 700    procedure Intersection
 701      (Target : in out Set;
 702       Source : Set)
 703    is
 704       Tgt_Node : Node_Access;
 705
 706    begin
 707       if Target'Address = Source'Address then
 708          return;
 709       end if;
 710
 711       if Source.HT.Length = 0 then
 712          Clear (Target);
 713          return;
 714       end if;
 715
 716       if Target.HT.Busy > 0 then
 717          raise Program_Error with
 718            "attempt to tamper with elements (set is busy)";
 719       end if;
 720
 721       Tgt_Node := HT_Ops.First (Target.HT);
 722       while Tgt_Node /= null loop
 723          if Is_In (Source.HT, Tgt_Node) then
 724             Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 725
 726          else
 727             declare
 728                X : Node_Access := Tgt_Node;
 729             begin
 730                Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 731                HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
 732                Free (X);
 733             end;
 734          end if;
 735       end loop;
 736    end Intersection;
 737
 738    function Intersection (Left, Right : Set) return Set is
 739       Buckets : HT_Types.Buckets_Access;
 740       Length  : Count_Type;
 741
 742    begin
 743       if Left'Address = Right'Address then
 744          return Left;
 745       end if;
 746
 747       Length := Count_Type'Min (Left.Length, Right.Length);
 748
 749       if Length = 0 then
 750          return Empty_Set;
 751       end if;
 752
 753       declare
 754          Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
 755       begin
 756          Buckets := new Buckets_Type (0 .. Size - 1);
 757       end;
 758
 759       Length := 0;
 760
 761       Iterate_Left : declare
 762          procedure Process (L_Node : Node_Access);
 763
 764          procedure Iterate is
 765             new HT_Ops.Generic_Iteration (Process);
 766
 767          -------------
 768          -- Process --
 769          -------------
 770
 771          procedure Process (L_Node : Node_Access) is
 772          begin
 773             if Is_In (Right.HT, L_Node) then
 774                declare
 775                   J : constant Hash_Type :=
 776                         Hash (L_Node.Element) mod Buckets'Length;
 777
 778                   Bucket : Node_Access renames Buckets (J);
 779
 780                begin
 781                   Bucket := new Node_Type'(L_Node.Element, Bucket);
 782                end;
 783
 784                Length := Length + 1;
 785             end if;
 786          end Process;
 787
 788       --  Start of processing for Iterate_Left
 789
 790       begin
 791          Iterate (Left.HT);
 792       exception
 793          when others =>
 794             HT_Ops.Free_Hash_Table (Buckets);
 795             raise;
 796       end Iterate_Left;
 797
 798       return (Controlled with HT => (Buckets, Length, 0, 0));
 799    end Intersection;
 800
 801    --------------
 802    -- Is_Empty --
 803    --------------
 804
 805    function Is_Empty (Container : Set) return Boolean is
 806    begin
 807       return Container.HT.Length = 0;
 808    end Is_Empty;
 809
 810    -----------
 811    -- Is_In --
 812    -----------
 813
 814    function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is
 815    begin
 816       return Element_Keys.Find (HT, Key.Element) /= null;
 817    end Is_In;
 818
 819    ---------------
 820    -- Is_Subset --
 821    ---------------
 822
 823    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
 824       Subset_Node : Node_Access;
 825
 826    begin
 827       if Subset'Address = Of_Set'Address then
 828          return True;
 829       end if;
 830
 831       if Subset.Length > Of_Set.Length then
 832          return False;
 833       end if;
 834
 835       Subset_Node := HT_Ops.First (Subset.HT);
 836       while Subset_Node /= null loop
 837          if not Is_In (Of_Set.HT, Subset_Node) then
 838             return False;
 839          end if;
 840          Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
 841       end loop;
 842
 843       return True;
 844    end Is_Subset;
 845
 846    -------------
 847    -- Iterate --
 848    -------------
 849
 850    procedure Iterate
 851      (Container : Set;
 852       Process   : not null access procedure (Position : Cursor))
 853    is
 854       procedure Process_Node (Node : Node_Access);
 855       pragma Inline (Process_Node);
 856
 857       procedure Iterate is
 858          new HT_Ops.Generic_Iteration (Process_Node);
 859
 860       ------------------
 861       -- Process_Node --
 862       ------------------
 863
 864       procedure Process_Node (Node : Node_Access) is
 865       begin
 866          Process (Cursor'(Container'Unrestricted_Access, Node));
 867       end Process_Node;
 868
 869       B : Natural renames Container'Unrestricted_Access.HT.Busy;
 870
 871    --  Start of processing for Iterate
 872
 873    begin
 874       B := B + 1;
 875
 876       begin
 877          Iterate (Container.HT);
 878       exception
 879          when others =>
 880             B := B - 1;
 881             raise;
 882       end;
 883
 884       B := B - 1;
 885    end Iterate;
 886
 887    ------------
 888    -- Length --
 889    ------------
 890
 891    function Length (Container : Set) return Count_Type is
 892    begin
 893       return Container.HT.Length;
 894    end Length;
 895
 896    ----------
 897    -- Move --
 898    ----------
 899
 900    procedure Move (Target : in out Set; Source : in out Set) is
 901    begin
 902       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
 903    end Move;
 904
 905    ----------
 906    -- Next --
 907    ----------
 908
 909    function Next (Node : Node_Access) return Node_Access is
 910    begin
 911       return Node.Next;
 912    end Next;
 913
 914    function Next (Position : Cursor) return Cursor is
 915    begin
 916       if Position.Node = null then
 917          return No_Element;
 918       end if;
 919
 920       pragma Assert (Vet (Position), "bad cursor in Next");
 921
 922       declare
 923          HT   : Hash_Table_Type renames Position.Container.HT;
 924          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
 925
 926       begin
 927          if Node = null then
 928             return No_Element;
 929          end if;
 930
 931          return Cursor'(Position.Container, Node);
 932       end;
 933    end Next;
 934
 935    procedure Next (Position : in out Cursor) is
 936    begin
 937       Position := Next (Position);
 938    end Next;
 939
 940    -------------
 941    -- Overlap --
 942    -------------
 943
 944    function Overlap (Left, Right : Set) return Boolean is
 945       Left_Node : Node_Access;
 946
 947    begin
 948       if Right.Length = 0 then
 949          return False;
 950       end if;
 951
 952       if Left'Address = Right'Address then
 953          return True;
 954       end if;
 955
 956       Left_Node := HT_Ops.First (Left.HT);
 957       while Left_Node /= null loop
 958          if Is_In (Right.HT, Left_Node) then
 959             return True;
 960          end if;
 961          Left_Node := HT_Ops.Next (Left.HT, Left_Node);
 962       end loop;
 963
 964       return False;
 965    end Overlap;
 966
 967    -------------------
 968    -- Query_Element --
 969    -------------------
 970
 971    procedure Query_Element
 972      (Position : Cursor;
 973       Process  : not null access procedure (Element : Element_Type))
 974    is
 975    begin
 976       if Position.Node = null then
 977          raise Constraint_Error with
 978            "Position cursor of Query_Element equals No_Element";
 979       end if;
 980
 981       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 982
 983       declare
 984          HT : Hash_Table_Type renames Position.Container.HT;
 985
 986          B : Natural renames HT.Busy;
 987          L : Natural renames HT.Lock;
 988
 989       begin
 990          B := B + 1;
 991          L := L + 1;
 992
 993          begin
 994             Process (Position.Node.Element);
 995          exception
 996             when others =>
 997                L := L - 1;
 998                B := B - 1;
 999                raise;
1000          end;
1001
1002          L := L - 1;
1003          B := B - 1;
1004       end;
1005    end Query_Element;
1006
1007    ----------
1008    -- Read --
1009    ----------
1010
1011    procedure Read
1012      (Stream    : access Root_Stream_Type'Class;
1013       Container :    out Set)
1014    is
1015    begin
1016       Read_Nodes (Stream, Container.HT);
1017    end Read;
1018
1019    procedure Read
1020      (Stream : access Root_Stream_Type'Class;
1021       Item   : out Cursor)
1022    is
1023    begin
1024       raise Program_Error with "attempt to stream set cursor";
1025    end Read;
1026
1027    ---------------
1028    -- Read_Node --
1029    ---------------
1030
1031    function Read_Node (Stream : access Root_Stream_Type'Class)
1032      return Node_Access
1033    is
1034       Node : Node_Access := new Node_Type;
1035
1036    begin
1037       Element_Type'Read (Stream, Node.Element);
1038       return Node;
1039    exception
1040       when others =>
1041          Free (Node);
1042          raise;
1043    end Read_Node;
1044
1045    -------------
1046    -- Replace --
1047    -------------
1048
1049    procedure Replace
1050      (Container : in out Set;
1051       New_Item  : Element_Type)
1052    is
1053       Node : constant Node_Access :=
1054                Element_Keys.Find (Container.HT, New_Item);
1055
1056    begin
1057       if Node = null then
1058          raise Constraint_Error with
1059            "attempt to replace element not in set";
1060       end if;
1061
1062       if Container.HT.Lock > 0 then
1063          raise Program_Error with
1064            "attempt to tamper with cursors (set is locked)";
1065       end if;
1066
1067       Node.Element := New_Item;
1068    end Replace;
1069
1070    procedure Replace_Element
1071      (Container : in out Set;
1072       Position  : Cursor;
1073       New_Item  : Element_Type)
1074    is
1075    begin
1076       if Position.Node = null then
1077          raise Constraint_Error with
1078            "Position cursor equals No_Element";
1079       end if;
1080
1081       if Position.Container /= Container'Unrestricted_Access then
1082          raise Program_Error with
1083            "Position cursor designates wrong set";
1084       end if;
1085
1086       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1087
1088       Replace_Element (Container.HT, Position.Node, New_Item);
1089    end Replace_Element;
1090
1091    ----------------------
1092    -- Reserve_Capacity --
1093    ----------------------
1094
1095    procedure Reserve_Capacity
1096      (Container : in out Set;
1097       Capacity  : Count_Type)
1098    is
1099    begin
1100       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1101    end Reserve_Capacity;
1102
1103    --------------
1104    -- Set_Next --
1105    --------------
1106
1107    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1108    begin
1109       Node.Next := Next;
1110    end Set_Next;
1111
1112    --------------------------
1113    -- Symmetric_Difference --
1114    --------------------------
1115
1116    procedure Symmetric_Difference
1117      (Target : in out Set;
1118       Source : Set)
1119    is
1120    begin
1121       if Target'Address = Source'Address then
1122          Clear (Target);
1123          return;
1124       end if;
1125
1126       if Target.HT.Busy > 0 then
1127          raise Program_Error with
1128            "attempt to tamper with elements (set is busy)";
1129       end if;
1130
1131       declare
1132          N : constant Count_Type := Target.Length + Source.Length;
1133       begin
1134          if N > HT_Ops.Capacity (Target.HT) then
1135             HT_Ops.Reserve_Capacity (Target.HT, N);
1136          end if;
1137       end;
1138
1139       if Target.Length = 0 then
1140          Iterate_Source_When_Empty_Target : declare
1141             procedure Process (Src_Node : Node_Access);
1142
1143             procedure Iterate is
1144                new HT_Ops.Generic_Iteration (Process);
1145
1146             -------------
1147             -- Process --
1148             -------------
1149
1150             procedure Process (Src_Node : Node_Access) is
1151                E : Element_Type renames Src_Node.Element;
1152                B : Buckets_Type renames Target.HT.Buckets.all;
1153                J : constant Hash_Type := Hash (E) mod B'Length;
1154                N : Count_Type renames Target.HT.Length;
1155
1156             begin
1157                B (J) := new Node_Type'(E, B (J));
1158                N := N + 1;
1159             end Process;
1160
1161          --  Start of processing for Iterate_Source_When_Empty_Target
1162
1163          begin
1164             Iterate (Source.HT);
1165          end Iterate_Source_When_Empty_Target;
1166
1167       else
1168          Iterate_Source : declare
1169             procedure Process (Src_Node : Node_Access);
1170
1171             procedure Iterate is
1172                new HT_Ops.Generic_Iteration (Process);
1173
1174             -------------
1175             -- Process --
1176             -------------
1177
1178             procedure Process (Src_Node : Node_Access) is
1179                E : Element_Type renames Src_Node.Element;
1180                B : Buckets_Type renames Target.HT.Buckets.all;
1181                J : constant Hash_Type := Hash (E) mod B'Length;
1182                N : Count_Type renames Target.HT.Length;
1183
1184             begin
1185                if B (J) = null then
1186                   B (J) := new Node_Type'(E, null);
1187                   N := N + 1;
1188
1189                elsif Equivalent_Elements (E, B (J).Element) then
1190                   declare
1191                      X : Node_Access := B (J);
1192                   begin
1193                      B (J) := B (J).Next;
1194                      N := N - 1;
1195                      Free (X);
1196                   end;
1197
1198                else
1199                   declare
1200                      Prev : Node_Access := B (J);
1201                      Curr : Node_Access := Prev.Next;
1202
1203                   begin
1204                      while Curr /= null loop
1205                         if Equivalent_Elements (E, Curr.Element) then
1206                            Prev.Next := Curr.Next;
1207                            N := N - 1;
1208                            Free (Curr);
1209                            return;
1210                         end if;
1211
1212                         Prev := Curr;
1213                         Curr := Prev.Next;
1214                      end loop;
1215
1216                      B (J) := new Node_Type'(E, B (J));
1217                      N := N + 1;
1218                   end;
1219                end if;
1220             end Process;
1221
1222          --  Start of processing for Iterate_Source
1223
1224          begin
1225             Iterate (Source.HT);
1226          end Iterate_Source;
1227       end if;
1228    end Symmetric_Difference;
1229
1230    function Symmetric_Difference (Left, Right : Set) return Set is
1231       Buckets : HT_Types.Buckets_Access;
1232       Length  : Count_Type;
1233
1234    begin
1235       if Left'Address = Right'Address then
1236          return Empty_Set;
1237       end if;
1238
1239       if Right.Length = 0 then
1240          return Left;
1241       end if;
1242
1243       if Left.Length = 0 then
1244          return Right;
1245       end if;
1246
1247       declare
1248          Size : constant Hash_Type :=
1249                   Prime_Numbers.To_Prime (Left.Length + Right.Length);
1250       begin
1251          Buckets := new Buckets_Type (0 .. Size - 1);
1252       end;
1253
1254       Length := 0;
1255
1256       Iterate_Left : declare
1257          procedure Process (L_Node : Node_Access);
1258
1259          procedure Iterate is
1260             new HT_Ops.Generic_Iteration (Process);
1261
1262          -------------
1263          -- Process --
1264          -------------
1265
1266          procedure Process (L_Node : Node_Access) is
1267          begin
1268             if not Is_In (Right.HT, L_Node) then
1269                declare
1270                   E : Element_Type renames L_Node.Element;
1271                   J : constant Hash_Type := Hash (E) mod Buckets'Length;
1272
1273                begin
1274                   Buckets (J) := new Node_Type'(E, Buckets (J));
1275                   Length := Length + 1;
1276                end;
1277             end if;
1278          end Process;
1279
1280       --  Start of processing for Iterate_Left
1281
1282       begin
1283          Iterate (Left.HT);
1284       exception
1285          when others =>
1286             HT_Ops.Free_Hash_Table (Buckets);
1287             raise;
1288       end Iterate_Left;
1289
1290       Iterate_Right : declare
1291          procedure Process (R_Node : Node_Access);
1292
1293          procedure Iterate is
1294             new HT_Ops.Generic_Iteration (Process);
1295
1296          -------------
1297          -- Process --
1298          -------------
1299
1300          procedure Process (R_Node : Node_Access) is
1301          begin
1302             if not Is_In (Left.HT, R_Node) then
1303                declare
1304                   E : Element_Type renames R_Node.Element;
1305                   J : constant Hash_Type := Hash (E) mod Buckets'Length;
1306
1307                begin
1308                   Buckets (J) := new Node_Type'(E, Buckets (J));
1309                   Length := Length + 1;
1310                end;
1311             end if;
1312          end Process;
1313
1314       --  Start of processing for Iterate_Right
1315
1316       begin
1317          Iterate (Right.HT);
1318       exception
1319          when others =>
1320             HT_Ops.Free_Hash_Table (Buckets);
1321             raise;
1322       end Iterate_Right;
1323
1324       return (Controlled with HT => (Buckets, Length, 0, 0));
1325    end Symmetric_Difference;
1326
1327    ------------
1328    -- To_Set --
1329    ------------
1330
1331    function To_Set (New_Item : Element_Type) return Set is
1332       HT       : Hash_Table_Type;
1333       Node     : Node_Access;
1334       Inserted : Boolean;
1335
1336    begin
1337       Insert (HT, New_Item, Node, Inserted);
1338       return Set'(Controlled with HT);
1339    end To_Set;
1340
1341    -----------
1342    -- Union --
1343    -----------
1344
1345    procedure Union
1346      (Target : in out Set;
1347       Source : Set)
1348    is
1349       procedure Process (Src_Node : Node_Access);
1350
1351       procedure Iterate is
1352          new HT_Ops.Generic_Iteration (Process);
1353
1354       -------------
1355       -- Process --
1356       -------------
1357
1358       procedure Process (Src_Node : Node_Access) is
1359          function New_Node (Next : Node_Access) return Node_Access;
1360          pragma Inline (New_Node);
1361
1362          procedure Insert is
1363             new Element_Keys.Generic_Conditional_Insert (New_Node);
1364
1365          --------------
1366          -- New_Node --
1367          --------------
1368
1369          function New_Node (Next : Node_Access) return Node_Access is
1370             Node : constant Node_Access :=
1371                      new Node_Type'(Src_Node.Element, Next);
1372          begin
1373             return Node;
1374          end New_Node;
1375
1376          Tgt_Node : Node_Access;
1377          Success  : Boolean;
1378
1379       --  Start of processing for Process
1380
1381       begin
1382          Insert (Target.HT, Src_Node.Element, Tgt_Node, Success);
1383       end Process;
1384
1385    --  Start of processing for Union
1386
1387    begin
1388       if Target'Address = Source'Address then
1389          return;
1390       end if;
1391
1392       if Target.HT.Busy > 0 then
1393          raise Program_Error with
1394            "attempt to tamper with elements (set is busy)";
1395       end if;
1396
1397       declare
1398          N : constant Count_Type := Target.Length + Source.Length;
1399       begin
1400          if N > HT_Ops.Capacity (Target.HT) then
1401             HT_Ops.Reserve_Capacity (Target.HT, N);
1402          end if;
1403       end;
1404
1405       Iterate (Source.HT);
1406    end Union;
1407
1408    function Union (Left, Right : Set) return Set is
1409       Buckets : HT_Types.Buckets_Access;
1410       Length  : Count_Type;
1411
1412    begin
1413       if Left'Address = Right'Address then
1414          return Left;
1415       end if;
1416
1417       if Right.Length = 0 then
1418          return Left;
1419       end if;
1420
1421       if Left.Length = 0 then
1422          return Right;
1423       end if;
1424
1425       declare
1426          Size : constant Hash_Type :=
1427                   Prime_Numbers.To_Prime (Left.Length + Right.Length);
1428       begin
1429          Buckets := new Buckets_Type (0 .. Size - 1);
1430       end;
1431
1432       Iterate_Left : declare
1433          procedure Process (L_Node : Node_Access);
1434
1435          procedure Iterate is
1436             new HT_Ops.Generic_Iteration (Process);
1437
1438          -------------
1439          -- Process --
1440          -------------
1441
1442          procedure Process (L_Node : Node_Access) is
1443             J : constant Hash_Type :=
1444                   Hash (L_Node.Element) mod Buckets'Length;
1445
1446          begin
1447             Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J));
1448          end Process;
1449
1450       --  Start of processing for Iterate_Left
1451
1452       begin
1453          Iterate (Left.HT);
1454       exception
1455          when others =>
1456             HT_Ops.Free_Hash_Table (Buckets);
1457             raise;
1458       end Iterate_Left;
1459
1460       Length := Left.Length;
1461
1462       Iterate_Right : declare
1463          procedure Process (Src_Node : Node_Access);
1464
1465          procedure Iterate is
1466             new HT_Ops.Generic_Iteration (Process);
1467
1468          -------------
1469          -- Process --
1470          -------------
1471
1472          procedure Process (Src_Node : Node_Access) is
1473             J : constant Hash_Type :=
1474                   Hash (Src_Node.Element) mod Buckets'Length;
1475
1476             Tgt_Node : Node_Access := Buckets (J);
1477
1478          begin
1479             while Tgt_Node /= null loop
1480                if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then
1481                   return;
1482                end if;
1483
1484                Tgt_Node := Next (Tgt_Node);
1485             end loop;
1486
1487             Buckets (J) := new Node_Type'(Src_Node.Element, Buckets (J));
1488             Length := Length + 1;
1489          end Process;
1490
1491       --  Start of processing for Iterate_Right
1492
1493       begin
1494          Iterate (Right.HT);
1495       exception
1496          when others =>
1497             HT_Ops.Free_Hash_Table (Buckets);
1498             raise;
1499       end Iterate_Right;
1500
1501       return (Controlled with HT => (Buckets, Length, 0, 0));
1502    end Union;
1503
1504    ---------
1505    -- Vet --
1506    ---------
1507
1508    function Vet (Position : Cursor) return Boolean is
1509    begin
1510       if Position.Node = null then
1511          return Position.Container = null;
1512       end if;
1513
1514       if Position.Container = null then
1515          return False;
1516       end if;
1517
1518       if Position.Node.Next = Position.Node then
1519          return False;
1520       end if;
1521
1522       declare
1523          HT : Hash_Table_Type renames Position.Container.HT;
1524          X  : Node_Access;
1525
1526       begin
1527          if HT.Length = 0 then
1528             return False;
1529          end if;
1530
1531          if HT.Buckets = null
1532            or else HT.Buckets'Length = 0
1533          then
1534             return False;
1535          end if;
1536
1537          X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element));
1538
1539          for J in 1 .. HT.Length loop
1540             if X = Position.Node then
1541                return True;
1542             end if;
1543
1544             if X = null then
1545                return False;
1546             end if;
1547
1548             if X = X.Next then  --  to prevent unnecessary looping
1549                return False;
1550             end if;
1551
1552             X := X.Next;
1553          end loop;
1554
1555          return False;
1556       end;
1557    end Vet;
1558
1559    -----------
1560    -- Write --
1561    -----------
1562
1563    procedure Write
1564      (Stream    : access Root_Stream_Type'Class;
1565       Container : Set)
1566    is
1567    begin
1568       Write_Nodes (Stream, Container.HT);
1569    end Write;
1570
1571    procedure Write
1572      (Stream : access Root_Stream_Type'Class;
1573       Item   : Cursor)
1574    is
1575    begin
1576       raise Program_Error with "attempt to stream set cursor";
1577    end Write;
1578
1579    ----------------
1580    -- Write_Node --
1581    ----------------
1582
1583    procedure Write_Node
1584      (Stream : access Root_Stream_Type'Class;
1585       Node   : Node_Access)
1586    is
1587    begin
1588       Element_Type'Write (Stream, Node.Element);
1589    end Write_Node;
1590
1591    package body Generic_Keys is
1592
1593       -----------------------
1594       -- Local Subprograms --
1595       -----------------------
1596
1597       function Equivalent_Key_Node
1598         (Key  : Key_Type;
1599          Node : Node_Access) return Boolean;
1600       pragma Inline (Equivalent_Key_Node);
1601
1602       --------------------------
1603       -- Local Instantiations --
1604       --------------------------
1605
1606       package Key_Keys is
1607          new Hash_Tables.Generic_Keys
1608           (HT_Types  => HT_Types,
1609            Next      => Next,
1610            Set_Next  => Set_Next,
1611            Key_Type  => Key_Type,
1612            Hash      => Hash,
1613            Equivalent_Keys => Equivalent_Key_Node);
1614
1615       --------------
1616       -- Contains --
1617       --------------
1618
1619       function Contains
1620         (Container : Set;
1621          Key       : Key_Type) return Boolean
1622       is
1623       begin
1624          return Find (Container, Key) /= No_Element;
1625       end Contains;
1626
1627       ------------
1628       -- Delete --
1629       ------------
1630
1631       procedure Delete
1632         (Container : in out Set;
1633          Key       : Key_Type)
1634       is
1635          X : Node_Access;
1636
1637       begin
1638          Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1639
1640          if X = null then
1641             raise Constraint_Error with "attempt to delete key not in set";
1642          end if;
1643
1644          Free (X);
1645       end Delete;
1646
1647       -------------
1648       -- Element --
1649       -------------
1650
1651       function Element
1652         (Container : Set;
1653          Key       : Key_Type) return Element_Type
1654       is
1655          Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1656
1657       begin
1658          if Node = null then
1659             raise Constraint_Error with "key not in map";
1660          end if;
1661
1662          return Node.Element;
1663       end Element;
1664
1665       -------------------------
1666       -- Equivalent_Key_Node --
1667       -------------------------
1668
1669       function Equivalent_Key_Node
1670         (Key  : Key_Type;
1671          Node : Node_Access) return Boolean
1672       is
1673       begin
1674          return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
1675       end Equivalent_Key_Node;
1676
1677       -------------
1678       -- Exclude --
1679       -------------
1680
1681       procedure Exclude
1682         (Container : in out Set;
1683          Key       : Key_Type)
1684       is
1685          X : Node_Access;
1686       begin
1687          Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1688          Free (X);
1689       end Exclude;
1690
1691       ----------
1692       -- Find --
1693       ----------
1694
1695       function Find
1696         (Container : Set;
1697          Key       : Key_Type) return Cursor
1698       is
1699          Node : constant Node_Access :=
1700                   Key_Keys.Find (Container.HT, Key);
1701
1702       begin
1703          if Node = null then
1704             return No_Element;
1705          end if;
1706
1707          return Cursor'(Container'Unrestricted_Access, Node);
1708       end Find;
1709
1710       ---------
1711       -- Key --
1712       ---------
1713
1714       function Key (Position : Cursor) return Key_Type is
1715       begin
1716          if Position.Node = null then
1717             raise Constraint_Error with
1718               "Position cursor equals No_Element";
1719          end if;
1720
1721          pragma Assert (Vet (Position), "bad cursor in function Key");
1722
1723          return Key (Position.Node.Element);
1724       end Key;
1725
1726       -------------
1727       -- Replace --
1728       -------------
1729
1730       procedure Replace
1731         (Container : in out Set;
1732          Key       : Key_Type;
1733          New_Item  : Element_Type)
1734       is
1735          Node : constant Node_Access :=
1736                   Key_Keys.Find (Container.HT, Key);
1737
1738       begin
1739          if Node = null then
1740             raise Constraint_Error with
1741               "attempt to replace key not in set";
1742          end if;
1743
1744          Replace_Element (Container.HT, Node, New_Item);
1745       end Replace;
1746
1747       -----------------------------------
1748       -- Update_Element_Preserving_Key --
1749       -----------------------------------
1750
1751       procedure Update_Element_Preserving_Key
1752         (Container : in out Set;
1753          Position  : Cursor;
1754          Process   : not null access
1755                        procedure (Element : in out Element_Type))
1756       is
1757          HT   : Hash_Table_Type renames Container.HT;
1758          Indx : Hash_Type;
1759
1760       begin
1761          if Position.Node = null then
1762             raise Constraint_Error with
1763               "Position cursor equals No_Element";
1764          end if;
1765
1766          if Position.Container /= Container'Unrestricted_Access then
1767             raise Program_Error with
1768               "Position cursor designates wrong set";
1769          end if;
1770
1771          if HT.Buckets = null
1772            or else HT.Buckets'Length = 0
1773            or else HT.Length = 0
1774            or else Position.Node.Next = Position.Node
1775          then
1776             raise Program_Error with "Position cursor is bad (set is empty)";
1777          end if;
1778
1779          pragma Assert
1780            (Vet (Position),
1781             "bad cursor in Update_Element_Preserving_Key");
1782
1783          Indx := HT_Ops.Index (HT, Position.Node);
1784
1785          declare
1786             E : Element_Type renames Position.Node.Element;
1787             K : constant Key_Type := Key (E);
1788
1789             B : Natural renames HT.Busy;
1790             L : Natural renames HT.Lock;
1791
1792          begin
1793             B := B + 1;
1794             L := L + 1;
1795
1796             begin
1797                Process (E);
1798             exception
1799                when others =>
1800                   L := L - 1;
1801                   B := B - 1;
1802                   raise;
1803             end;
1804
1805             L := L - 1;
1806             B := B - 1;
1807
1808             if Equivalent_Keys (K, Key (E)) then
1809                pragma Assert (Hash (K) = Hash (E));
1810                return;
1811             end if;
1812          end;
1813
1814          if HT.Buckets (Indx) = Position.Node then
1815             HT.Buckets (Indx) := Position.Node.Next;
1816
1817          else
1818             declare
1819                Prev : Node_Access := HT.Buckets (Indx);
1820
1821             begin
1822                while Prev.Next /= Position.Node loop
1823                   Prev := Prev.Next;
1824
1825                   if Prev = null then
1826                      raise Program_Error with
1827                        "Position cursor is bad (node not found)";
1828                   end if;
1829                end loop;
1830
1831                Prev.Next := Position.Node.Next;
1832             end;
1833          end if;
1834
1835          HT.Length := HT.Length - 1;
1836
1837          declare
1838             X : Node_Access := Position.Node;
1839
1840          begin
1841             Free (X);
1842          end;
1843
1844          raise Program_Error with "key was modified";
1845       end Update_Element_Preserving_Key;
1846
1847    end Generic_Keys;
1848
1849 end Ada.Containers.Hashed_Sets;