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