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