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