gcc/ada/a-cihase.adb

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