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