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