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-2014, 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    procedure Finalize (Object : in out Iterator) is
 605    begin
 606       if Object.Container /= null then
 607          declare
 608             B : Natural renames Object.Container.HT.Busy;
 609          begin
 610             B := B - 1;
 611          end;
 612       end if;
 613    end Finalize;
 614
 615    ----------
 616    -- Find --
 617    ----------
 618
 619    function Find
 620      (Container : Set;
 621       Item      : Element_Type) return Cursor
 622    is
 623       HT   : Hash_Table_Type renames Container'Unrestricted_Access.HT;
 624       Node : constant Node_Access := Element_Keys.Find (HT, Item);
 625
 626    begin
 627       if Node = null then
 628          return No_Element;
 629       end if;
 630
 631       return Cursor'(Container'Unrestricted_Access, Node);
 632    end Find;
 633
 634    --------------------
 635    -- Find_Equal_Key --
 636    --------------------
 637
 638    function Find_Equal_Key
 639      (R_HT   : Hash_Table_Type;
 640       L_Node : Node_Access) return Boolean
 641    is
 642       R_Index : constant Hash_Type :=
 643         Element_Keys.Index (R_HT, L_Node.Element);
 644
 645       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 646
 647    begin
 648       loop
 649          if R_Node = null then
 650             return False;
 651          end if;
 652
 653          if L_Node.Element = R_Node.Element then
 654             return True;
 655          end if;
 656
 657          R_Node := Next (R_Node);
 658       end loop;
 659    end Find_Equal_Key;
 660
 661    -------------------------
 662    -- Find_Equivalent_Key --
 663    -------------------------
 664
 665    function Find_Equivalent_Key
 666      (R_HT   : Hash_Table_Type;
 667       L_Node : Node_Access) return Boolean
 668    is
 669       R_Index : constant Hash_Type :=
 670         Element_Keys.Index (R_HT, L_Node.Element);
 671
 672       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 673
 674    begin
 675       loop
 676          if R_Node = null then
 677             return False;
 678          end if;
 679
 680          if Equivalent_Elements (L_Node.Element, R_Node.Element) then
 681             return True;
 682          end if;
 683
 684          R_Node := Next (R_Node);
 685       end loop;
 686    end Find_Equivalent_Key;
 687
 688    -----------
 689    -- First --
 690    -----------
 691
 692    function First (Container : Set) return Cursor is
 693       Node : constant Node_Access := HT_Ops.First (Container.HT);
 694
 695    begin
 696       if Node = null then
 697          return No_Element;
 698       end if;
 699
 700       return Cursor'(Container'Unrestricted_Access, Node);
 701    end First;
 702
 703    function First (Object : Iterator) return Cursor is
 704    begin
 705       return Object.Container.First;
 706    end First;
 707
 708    ----------
 709    -- Free --
 710    ----------
 711
 712    procedure Free (X : in out Node_Access) is
 713       procedure Deallocate is
 714          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 715
 716    begin
 717       if X /= null then
 718          X.Next := X;     --  detect mischief (in Vet)
 719          Deallocate (X);
 720       end if;
 721    end Free;
 722
 723    -----------------
 724    -- Has_Element --
 725    -----------------
 726
 727    function Has_Element (Position : Cursor) return Boolean is
 728    begin
 729       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 730       return Position.Node /= null;
 731    end Has_Element;
 732
 733    ---------------
 734    -- Hash_Node --
 735    ---------------
 736
 737    function Hash_Node (Node : Node_Access) return Hash_Type is
 738    begin
 739       return Hash (Node.Element);
 740    end Hash_Node;
 741
 742    -------------
 743    -- Include --
 744    -------------
 745
 746    procedure Include
 747      (Container : in out Set;
 748       New_Item  : Element_Type)
 749    is
 750       Position : Cursor;
 751       Inserted : Boolean;
 752
 753    begin
 754       Insert (Container, New_Item, Position, Inserted);
 755
 756       if not Inserted then
 757          if Container.HT.Lock > 0 then
 758             raise Program_Error with
 759               "attempt to tamper with elements (set is locked)";
 760          end if;
 761
 762          Position.Node.Element := New_Item;
 763       end if;
 764    end Include;
 765
 766    ------------
 767    -- Insert --
 768    ------------
 769
 770    procedure Insert
 771      (Container : in out Set;
 772       New_Item  : Element_Type;
 773       Position  : out Cursor;
 774       Inserted  : out Boolean)
 775    is
 776    begin
 777       Insert (Container.HT, New_Item, Position.Node, Inserted);
 778       Position.Container := Container'Unchecked_Access;
 779    end Insert;
 780
 781    procedure Insert
 782      (Container : in out Set;
 783       New_Item  : Element_Type)
 784    is
 785       Position : Cursor;
 786       pragma Unreferenced (Position);
 787
 788       Inserted : Boolean;
 789
 790    begin
 791       Insert (Container, New_Item, Position, Inserted);
 792
 793       if not Inserted then
 794          raise Constraint_Error with
 795            "attempt to insert element already in set";
 796       end if;
 797    end Insert;
 798
 799    procedure Insert
 800      (HT       : in out Hash_Table_Type;
 801       New_Item : Element_Type;
 802       Node     : out Node_Access;
 803       Inserted : out Boolean)
 804    is
 805       function New_Node (Next : Node_Access) return Node_Access;
 806       pragma Inline (New_Node);
 807
 808       procedure Local_Insert is
 809         new Element_Keys.Generic_Conditional_Insert (New_Node);
 810
 811       --------------
 812       -- New_Node --
 813       --------------
 814
 815       function New_Node (Next : Node_Access) return Node_Access is
 816       begin
 817          return new Node_Type'(New_Item, Next);
 818       end New_Node;
 819
 820    --  Start of processing for Insert
 821
 822    begin
 823       if HT_Ops.Capacity (HT) = 0 then
 824          HT_Ops.Reserve_Capacity (HT, 1);
 825       end if;
 826
 827       if HT.Busy > 0 then
 828          raise Program_Error with
 829            "attempt to tamper with cursors (set is busy)";
 830       end if;
 831
 832       Local_Insert (HT, New_Item, Node, Inserted);
 833
 834       if Inserted
 835         and then HT.Length > HT_Ops.Capacity (HT)
 836       then
 837          HT_Ops.Reserve_Capacity (HT, HT.Length);
 838       end if;
 839    end Insert;
 840
 841    ------------------
 842    -- Intersection --
 843    ------------------
 844
 845    procedure Intersection
 846      (Target : in out Set;
 847       Source : Set)
 848    is
 849       Src_HT   : Hash_Table_Type renames Source'Unrestricted_Access.HT;
 850       Tgt_Node : Node_Access;
 851
 852    begin
 853       if Target'Address = Source'Address then
 854          return;
 855       end if;
 856
 857       if Source.HT.Length = 0 then
 858          Clear (Target);
 859          return;
 860       end if;
 861
 862       if Target.HT.Busy > 0 then
 863          raise Program_Error with
 864            "attempt to tamper with cursors (set is busy)";
 865       end if;
 866
 867       Tgt_Node := HT_Ops.First (Target.HT);
 868       while Tgt_Node /= null loop
 869          if Is_In (Src_HT, Tgt_Node) then
 870             Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 871
 872          else
 873             declare
 874                X : Node_Access := Tgt_Node;
 875             begin
 876                Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 877                HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
 878                Free (X);
 879             end;
 880          end if;
 881       end loop;
 882    end Intersection;
 883
 884    function Intersection (Left, Right : Set) return Set is
 885       Left_HT  : Hash_Table_Type renames Left'Unrestricted_Access.HT;
 886       Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
 887       Buckets  : HT_Types.Buckets_Access;
 888       Length   : Count_Type;
 889
 890    begin
 891       if Left'Address = Right'Address then
 892          return Left;
 893       end if;
 894
 895       Length := Count_Type'Min (Left.Length, Right.Length);
 896
 897       if Length = 0 then
 898          return Empty_Set;
 899       end if;
 900
 901       declare
 902          Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
 903       begin
 904          Buckets := HT_Ops.New_Buckets (Length => Size);
 905       end;
 906
 907       Length := 0;
 908
 909       Iterate_Left : declare
 910          procedure Process (L_Node : Node_Access);
 911
 912          procedure Iterate is
 913             new HT_Ops.Generic_Iteration (Process);
 914
 915          -------------
 916          -- Process --
 917          -------------
 918
 919          procedure Process (L_Node : Node_Access) is
 920          begin
 921             if Is_In (Right_HT, L_Node) then
 922                declare
 923                   --  Per AI05-0022, the container implementation is required
 924                   --  to detect element tampering by a generic actual
 925                   --  subprogram, hence the use of Checked_Index instead of a
 926                   --  simple invocation of generic formal Hash.
 927
 928                   J : constant Hash_Type :=
 929                     HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
 930
 931                   Bucket : Node_Access renames Buckets (J);
 932
 933                begin
 934                   Bucket := new Node_Type'(L_Node.Element, Bucket);
 935                end;
 936
 937                Length := Length + 1;
 938             end if;
 939          end Process;
 940
 941       --  Start of processing for Iterate_Left
 942
 943       begin
 944          Iterate (Left_HT);
 945       exception
 946          when others =>
 947             HT_Ops.Free_Hash_Table (Buckets);
 948             raise;
 949       end Iterate_Left;
 950
 951       return (Controlled with HT => (Buckets, Length, 0, 0));
 952    end Intersection;
 953
 954    --------------
 955    -- Is_Empty --
 956    --------------
 957
 958    function Is_Empty (Container : Set) return Boolean is
 959    begin
 960       return Container.HT.Length = 0;
 961    end Is_Empty;
 962
 963    -----------
 964    -- Is_In --
 965    -----------
 966
 967    function Is_In
 968      (HT : aliased in out Hash_Table_Type;
 969       Key : Node_Access) return Boolean
 970    is
 971    begin
 972       return Element_Keys.Find (HT, Key.Element) /= null;
 973    end Is_In;
 974
 975    ---------------
 976    -- Is_Subset --
 977    ---------------
 978
 979    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
 980       Subset_HT   : Hash_Table_Type renames Subset'Unrestricted_Access.HT;
 981       Of_Set_HT   : Hash_Table_Type renames Of_Set'Unrestricted_Access.HT;
 982       Subset_Node : Node_Access;
 983
 984    begin
 985       if Subset'Address = Of_Set'Address then
 986          return True;
 987       end if;
 988
 989       if Subset.Length > Of_Set.Length then
 990          return False;
 991       end if;
 992
 993       Subset_Node := HT_Ops.First (Subset_HT);
 994       while Subset_Node /= null loop
 995          if not Is_In (Of_Set_HT, Subset_Node) then
 996             return False;
 997          end if;
 998          Subset_Node := HT_Ops.Next (Subset_HT, Subset_Node);
 999       end loop;
1000
1001       return True;
1002    end Is_Subset;
1003
1004    -------------
1005    -- Iterate --
1006    -------------
1007
1008    procedure Iterate
1009      (Container : Set;
1010       Process   : not null access procedure (Position : Cursor))
1011    is
1012       procedure Process_Node (Node : Node_Access);
1013       pragma Inline (Process_Node);
1014
1015       procedure Iterate is
1016          new HT_Ops.Generic_Iteration (Process_Node);
1017
1018       ------------------
1019       -- Process_Node --
1020       ------------------
1021
1022       procedure Process_Node (Node : Node_Access) is
1023       begin
1024          Process (Cursor'(Container'Unrestricted_Access, Node));
1025       end Process_Node;
1026
1027       B : Natural renames Container'Unrestricted_Access.HT.Busy;
1028
1029    --  Start of processing for Iterate
1030
1031    begin
1032       B := B + 1;
1033
1034       begin
1035          Iterate (Container.HT);
1036       exception
1037          when others =>
1038             B := B - 1;
1039             raise;
1040       end;
1041
1042       B := B - 1;
1043    end Iterate;
1044
1045    function Iterate
1046      (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class
1047    is
1048       B  : Natural renames Container'Unrestricted_Access.all.HT.Busy;
1049    begin
1050       B := B + 1;
1051       return It : constant Iterator :=
1052          Iterator'(Limited_Controlled with
1053               Container => Container'Unrestricted_Access);
1054    end Iterate;
1055
1056    ------------
1057    -- Length --
1058    ------------
1059
1060    function Length (Container : Set) return Count_Type is
1061    begin
1062       return Container.HT.Length;
1063    end Length;
1064
1065    ----------
1066    -- Move --
1067    ----------
1068
1069    procedure Move (Target : in out Set; Source : in out Set) is
1070    begin
1071       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
1072    end Move;
1073
1074    ----------
1075    -- Next --
1076    ----------
1077
1078    function Next (Node : Node_Access) return Node_Access is
1079    begin
1080       return Node.Next;
1081    end Next;
1082
1083    function Next (Position : Cursor) return Cursor is
1084    begin
1085       if Position.Node = null then
1086          return No_Element;
1087       end if;
1088
1089       pragma Assert (Vet (Position), "bad cursor in Next");
1090
1091       declare
1092          HT   : Hash_Table_Type renames Position.Container.HT;
1093          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
1094
1095       begin
1096          if Node = null then
1097             return No_Element;
1098          end if;
1099
1100          return Cursor'(Position.Container, Node);
1101       end;
1102    end Next;
1103
1104    procedure Next (Position : in out Cursor) is
1105    begin
1106       Position := Next (Position);
1107    end Next;
1108
1109    function Next
1110      (Object   : Iterator;
1111       Position : Cursor) return Cursor
1112    is
1113    begin
1114       if Position.Container = null then
1115          return No_Element;
1116       end if;
1117
1118       if Position.Container /= Object.Container then
1119          raise Program_Error with
1120            "Position cursor of Next designates wrong set";
1121       end if;
1122
1123       return Next (Position);
1124    end Next;
1125
1126    -------------
1127    -- Overlap --
1128    -------------
1129
1130    function Overlap (Left, Right : Set) return Boolean is
1131       Left_HT   : Hash_Table_Type renames Left'Unrestricted_Access.HT;
1132       Right_HT  : Hash_Table_Type renames Right'Unrestricted_Access.HT;
1133       Left_Node : Node_Access;
1134
1135    begin
1136       if Right.Length = 0 then
1137          return False;
1138       end if;
1139
1140       if Left'Address = Right'Address then
1141          return True;
1142       end if;
1143
1144       Left_Node := HT_Ops.First (Left_HT);
1145       while Left_Node /= null loop
1146          if Is_In (Right_HT, Left_Node) then
1147             return True;
1148          end if;
1149          Left_Node := HT_Ops.Next (Left_HT, Left_Node);
1150       end loop;
1151
1152       return False;
1153    end Overlap;
1154
1155    -------------------
1156    -- Query_Element --
1157    -------------------
1158
1159    procedure Query_Element
1160      (Position : Cursor;
1161       Process  : not null access procedure (Element : Element_Type))
1162    is
1163    begin
1164       if Position.Node = null then
1165          raise Constraint_Error with
1166            "Position cursor of Query_Element equals No_Element";
1167       end if;
1168
1169       pragma Assert (Vet (Position), "bad cursor in Query_Element");
1170
1171       declare
1172          HT : Hash_Table_Type renames Position.Container.HT;
1173
1174          B : Natural renames HT.Busy;
1175          L : Natural renames HT.Lock;
1176
1177       begin
1178          B := B + 1;
1179          L := L + 1;
1180
1181          begin
1182             Process (Position.Node.Element);
1183          exception
1184             when others =>
1185                L := L - 1;
1186                B := B - 1;
1187                raise;
1188          end;
1189
1190          L := L - 1;
1191          B := B - 1;
1192       end;
1193    end Query_Element;
1194
1195    ----------
1196    -- Read --
1197    ----------
1198
1199    procedure Read
1200      (Stream    : not null access Root_Stream_Type'Class;
1201       Container : out Set)
1202    is
1203    begin
1204       Read_Nodes (Stream, Container.HT);
1205    end Read;
1206
1207    procedure Read
1208      (Stream : not null access Root_Stream_Type'Class;
1209       Item   : out Cursor)
1210    is
1211    begin
1212       raise Program_Error with "attempt to stream set cursor";
1213    end Read;
1214
1215    procedure Read
1216      (Stream : not null access Root_Stream_Type'Class;
1217       Item   : out Constant_Reference_Type)
1218    is
1219    begin
1220       raise Program_Error with "attempt to stream reference";
1221    end Read;
1222
1223    ---------------
1224    -- Read_Node --
1225    ---------------
1226
1227    function Read_Node (Stream : not null access Root_Stream_Type'Class)
1228      return Node_Access
1229    is
1230       Node : Node_Access := new Node_Type;
1231    begin
1232       Element_Type'Read (Stream, Node.Element);
1233       return Node;
1234    exception
1235       when others =>
1236          Free (Node);
1237          raise;
1238    end Read_Node;
1239
1240    -------------
1241    -- Replace --
1242    -------------
1243
1244    procedure Replace
1245      (Container : in out Set;
1246       New_Item  : Element_Type)
1247    is
1248       Node : constant Node_Access :=
1249         Element_Keys.Find (Container.HT, New_Item);
1250
1251    begin
1252       if Node = null then
1253          raise Constraint_Error with
1254            "attempt to replace element not in set";
1255       end if;
1256
1257       if Container.HT.Lock > 0 then
1258          raise Program_Error with
1259            "attempt to tamper with elements (set is locked)";
1260       end if;
1261
1262       Node.Element := New_Item;
1263    end Replace;
1264
1265    procedure Replace_Element
1266      (Container : in out Set;
1267       Position  : Cursor;
1268       New_Item  : Element_Type)
1269    is
1270    begin
1271       if Position.Node = null then
1272          raise Constraint_Error with
1273            "Position cursor equals No_Element";
1274       end if;
1275
1276       if Position.Container /= Container'Unrestricted_Access then
1277          raise Program_Error with
1278            "Position cursor designates wrong set";
1279       end if;
1280
1281       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1282
1283       Replace_Element (Container.HT, Position.Node, New_Item);
1284    end Replace_Element;
1285
1286    ----------------------
1287    -- Reserve_Capacity --
1288    ----------------------
1289
1290    procedure Reserve_Capacity
1291      (Container : in out Set;
1292       Capacity  : Count_Type)
1293    is
1294    begin
1295       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1296    end Reserve_Capacity;
1297
1298    --------------
1299    -- Set_Next --
1300    --------------
1301
1302    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1303    begin
1304       Node.Next := Next;
1305    end Set_Next;
1306
1307    --------------------------
1308    -- Symmetric_Difference --
1309    --------------------------
1310
1311    procedure Symmetric_Difference
1312      (Target : in out Set;
1313       Source : Set)
1314    is
1315       Tgt_HT : Hash_Table_Type renames Target.HT;
1316       Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all;
1317
1318       --  Per AI05-0022, the container implementation is required to detect
1319       --  element tampering by a generic actual subprogram.
1320
1321       TB : Natural renames Tgt_HT.Busy;
1322       TL : Natural renames Tgt_HT.Lock;
1323
1324       SB : Natural renames Src_HT.Busy;
1325       SL : Natural renames Src_HT.Lock;
1326
1327    begin
1328       if Target'Address = Source'Address then
1329          Clear (Target);
1330          return;
1331       end if;
1332
1333       if TB > 0 then
1334          raise Program_Error with
1335            "attempt to tamper with cursors (set is busy)";
1336       end if;
1337
1338       declare
1339          N : constant Count_Type := Target.Length + Source.Length;
1340       begin
1341          if N > HT_Ops.Capacity (Tgt_HT) then
1342             HT_Ops.Reserve_Capacity (Tgt_HT, N);
1343          end if;
1344       end;
1345
1346       if Target.Length = 0 then
1347          Iterate_Source_When_Empty_Target : declare
1348             procedure Process (Src_Node : Node_Access);
1349
1350             procedure Iterate is
1351                new HT_Ops.Generic_Iteration (Process);
1352
1353             -------------
1354             -- Process --
1355             -------------
1356
1357             procedure Process (Src_Node : Node_Access) is
1358                E : Element_Type renames Src_Node.Element;
1359                B : Buckets_Type renames Tgt_HT.Buckets.all;
1360                J : constant Hash_Type := Hash (E) mod B'Length;
1361                N : Count_Type renames Tgt_HT.Length;
1362
1363             begin
1364                B (J) := new Node_Type'(E, B (J));
1365                N := N + 1;
1366             end Process;
1367
1368          --  Start of processing for Iterate_Source_When_Empty_Target
1369
1370          begin
1371             TB := TB + 1;
1372             TL := TL + 1;
1373
1374             SB := SB + 1;
1375             SL := SL + 1;
1376
1377             Iterate (Src_HT);
1378
1379             SL := SL - 1;
1380             SB := SB - 1;
1381
1382             TL := TL - 1;
1383             TB := TB - 1;
1384
1385          exception
1386             when others =>
1387                SL := SL - 1;
1388                SB := SB - 1;
1389
1390                TL := TL - 1;
1391                TB := TB - 1;
1392
1393                raise;
1394          end Iterate_Source_When_Empty_Target;
1395
1396       else
1397          Iterate_Source : declare
1398             procedure Process (Src_Node : Node_Access);
1399
1400             procedure Iterate is
1401                new HT_Ops.Generic_Iteration (Process);
1402
1403             -------------
1404             -- Process --
1405             -------------
1406
1407             procedure Process (Src_Node : Node_Access) is
1408                E : Element_Type renames Src_Node.Element;
1409                B : Buckets_Type renames Tgt_HT.Buckets.all;
1410                J : constant Hash_Type := Hash (E) mod B'Length;
1411                N : Count_Type renames Tgt_HT.Length;
1412
1413             begin
1414                if B (J) = null then
1415                   B (J) := new Node_Type'(E, null);
1416                   N := N + 1;
1417
1418                elsif Equivalent_Elements (E, B (J).Element) then
1419                   declare
1420                      X : Node_Access := B (J);
1421                   begin
1422                      B (J) := B (J).Next;
1423                      N := N - 1;
1424                      Free (X);
1425                   end;
1426
1427                else
1428                   declare
1429                      Prev : Node_Access := B (J);
1430                      Curr : Node_Access := Prev.Next;
1431
1432                   begin
1433                      while Curr /= null loop
1434                         if Equivalent_Elements (E, Curr.Element) then
1435                            Prev.Next := Curr.Next;
1436                            N := N - 1;
1437                            Free (Curr);
1438                            return;
1439                         end if;
1440
1441                         Prev := Curr;
1442                         Curr := Prev.Next;
1443                      end loop;
1444
1445                      B (J) := new Node_Type'(E, B (J));
1446                      N := N + 1;
1447                   end;
1448                end if;
1449             end Process;
1450
1451          --  Start of processing for Iterate_Source
1452
1453          begin
1454             TB := TB + 1;
1455             TL := TL + 1;
1456
1457             SB := SB + 1;
1458             SL := SL + 1;
1459
1460             Iterate (Src_HT);
1461
1462             SL := SL - 1;
1463             SB := SB - 1;
1464
1465             TL := TL - 1;
1466             TB := TB - 1;
1467
1468          exception
1469             when others =>
1470                SL := SL - 1;
1471                SB := SB - 1;
1472
1473                TL := TL - 1;
1474                TB := TB - 1;
1475
1476                raise;
1477          end Iterate_Source;
1478       end if;
1479    end Symmetric_Difference;
1480
1481    function Symmetric_Difference (Left, Right : Set) return Set is
1482       Left_HT  : Hash_Table_Type renames Left'Unrestricted_Access.HT;
1483       Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
1484       Buckets  : HT_Types.Buckets_Access;
1485       Length   : Count_Type;
1486
1487    begin
1488       if Left'Address = Right'Address then
1489          return Empty_Set;
1490       end if;
1491
1492       if Right.Length = 0 then
1493          return Left;
1494       end if;
1495
1496       if Left.Length = 0 then
1497          return Right;
1498       end if;
1499
1500       declare
1501          Size : constant Hash_Type :=
1502            Prime_Numbers.To_Prime (Left.Length + Right.Length);
1503       begin
1504          Buckets := HT_Ops.New_Buckets (Length => Size);
1505       end;
1506
1507       Length := 0;
1508
1509       Iterate_Left : declare
1510          procedure Process (L_Node : Node_Access);
1511
1512          procedure Iterate is
1513             new HT_Ops.Generic_Iteration (Process);
1514
1515          -------------
1516          -- Process --
1517          -------------
1518
1519          procedure Process (L_Node : Node_Access) is
1520          begin
1521             if not Is_In (Right_HT, L_Node) then
1522                declare
1523                   E : Element_Type renames L_Node.Element;
1524
1525                   --  Per AI05-0022, the container implementation is required
1526                   --  to detect element tampering by a generic actual
1527                   --  subprogram, hence the use of Checked_Index instead of a
1528                   --  simple invocation of generic formal Hash.
1529
1530                   J : constant Hash_Type :=
1531                     HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
1532
1533                begin
1534                   Buckets (J) := new Node_Type'(E, Buckets (J));
1535                   Length := Length + 1;
1536                end;
1537             end if;
1538          end Process;
1539
1540       --  Start of processing for Iterate_Left
1541
1542       begin
1543          Iterate (Left_HT);
1544
1545       exception
1546          when others =>
1547             HT_Ops.Free_Hash_Table (Buckets);
1548             raise;
1549       end Iterate_Left;
1550
1551       Iterate_Right : declare
1552          procedure Process (R_Node : Node_Access);
1553
1554          procedure Iterate is
1555             new HT_Ops.Generic_Iteration (Process);
1556
1557          -------------
1558          -- Process --
1559          -------------
1560
1561          procedure Process (R_Node : Node_Access) is
1562          begin
1563             if not Is_In (Left_HT, R_Node) then
1564                declare
1565                   E : Element_Type renames R_Node.Element;
1566
1567                   --  Per AI05-0022, the container implementation is required
1568                   --  to detect element tampering by a generic actual
1569                   --  subprogram, hence the use of Checked_Index instead of a
1570                   --  simple invocation of generic formal Hash.
1571
1572                   J : constant Hash_Type :=
1573                     HT_Ops.Checked_Index (Right_HT, Buckets.all, R_Node);
1574
1575                begin
1576                   Buckets (J) := new Node_Type'(E, Buckets (J));
1577                   Length := Length + 1;
1578                end;
1579             end if;
1580          end Process;
1581
1582       --  Start of processing for Iterate_Right
1583
1584       begin
1585          Iterate (Right_HT);
1586
1587       exception
1588          when others =>
1589             HT_Ops.Free_Hash_Table (Buckets);
1590             raise;
1591       end Iterate_Right;
1592
1593       return (Controlled with HT => (Buckets, Length, 0, 0));
1594    end Symmetric_Difference;
1595
1596    ------------
1597    -- To_Set --
1598    ------------
1599
1600    function To_Set (New_Item : Element_Type) return Set is
1601       HT : Hash_Table_Type;
1602
1603       Node     : Node_Access;
1604       Inserted : Boolean;
1605       pragma Unreferenced (Node, Inserted);
1606
1607    begin
1608       Insert (HT, New_Item, Node, Inserted);
1609       return Set'(Controlled with HT);
1610    end To_Set;
1611
1612    -----------
1613    -- Union --
1614    -----------
1615
1616    procedure Union
1617      (Target : in out Set;
1618       Source : Set)
1619    is
1620       procedure Process (Src_Node : Node_Access);
1621
1622       procedure Iterate is
1623          new HT_Ops.Generic_Iteration (Process);
1624
1625       -------------
1626       -- Process --
1627       -------------
1628
1629       procedure Process (Src_Node : Node_Access) is
1630          function New_Node (Next : Node_Access) return Node_Access;
1631          pragma Inline (New_Node);
1632
1633          procedure Insert is
1634             new Element_Keys.Generic_Conditional_Insert (New_Node);
1635
1636          --------------
1637          -- New_Node --
1638          --------------
1639
1640          function New_Node (Next : Node_Access) return Node_Access is
1641             Node : constant Node_Access :=
1642               new Node_Type'(Src_Node.Element, Next);
1643          begin
1644             return Node;
1645          end New_Node;
1646
1647          Tgt_Node : Node_Access;
1648          Success  : Boolean;
1649          pragma Unreferenced (Tgt_Node, Success);
1650
1651       --  Start of processing for Process
1652
1653       begin
1654          Insert (Target.HT, Src_Node.Element, Tgt_Node, Success);
1655       end Process;
1656
1657    --  Start of processing for Union
1658
1659    begin
1660       if Target'Address = Source'Address then
1661          return;
1662       end if;
1663
1664       if Target.HT.Busy > 0 then
1665          raise Program_Error with
1666            "attempt to tamper with cursors (set is busy)";
1667       end if;
1668
1669       declare
1670          N : constant Count_Type := Target.Length + Source.Length;
1671       begin
1672          if N > HT_Ops.Capacity (Target.HT) then
1673             HT_Ops.Reserve_Capacity (Target.HT, N);
1674          end if;
1675       end;
1676
1677       Iterate (Source.HT);
1678    end Union;
1679
1680    function Union (Left, Right : Set) return Set is
1681       Left_HT  : Hash_Table_Type renames Left.HT'Unrestricted_Access.all;
1682       Right_HT : Hash_Table_Type renames Right.HT'Unrestricted_Access.all;
1683       Buckets  : HT_Types.Buckets_Access;
1684       Length   : Count_Type;
1685
1686    begin
1687       if Left'Address = Right'Address then
1688          return Left;
1689       end if;
1690
1691       if Right.Length = 0 then
1692          return Left;
1693       end if;
1694
1695       if Left.Length = 0 then
1696          return Right;
1697       end if;
1698
1699       declare
1700          Size : constant Hash_Type :=
1701            Prime_Numbers.To_Prime (Left.Length + Right.Length);
1702       begin
1703          Buckets := HT_Ops.New_Buckets (Length => Size);
1704       end;
1705
1706       Iterate_Left : declare
1707          procedure Process (L_Node : Node_Access);
1708
1709          procedure Iterate is
1710             new HT_Ops.Generic_Iteration (Process);
1711
1712          -------------
1713          -- Process --
1714          -------------
1715
1716          procedure Process (L_Node : Node_Access) is
1717             J : constant Hash_Type :=
1718               Hash (L_Node.Element) mod Buckets'Length;
1719
1720          begin
1721             Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J));
1722          end Process;
1723
1724          --  Per AI05-0022, the container implementation is required to detect
1725          --  element tampering by a generic actual subprogram, hence the use of
1726          --  Checked_Index instead of a simple invocation of generic formal
1727          --  Hash.
1728
1729          B : Integer renames Left_HT.Busy;
1730          L : Integer renames Left_HT.Lock;
1731
1732       --  Start of processing for Iterate_Left
1733
1734       begin
1735          B := B + 1;
1736          L := L + 1;
1737
1738          Iterate (Left_HT);
1739
1740          L := L - 1;
1741          B := B - 1;
1742
1743       exception
1744          when others =>
1745             L := L - 1;
1746             B := B - 1;
1747
1748             HT_Ops.Free_Hash_Table (Buckets);
1749             raise;
1750       end Iterate_Left;
1751
1752       Length := Left.Length;
1753
1754       Iterate_Right : declare
1755          procedure Process (Src_Node : Node_Access);
1756
1757          procedure Iterate is
1758             new HT_Ops.Generic_Iteration (Process);
1759
1760          -------------
1761          -- Process --
1762          -------------
1763
1764          procedure Process (Src_Node : Node_Access) is
1765             J : constant Hash_Type :=
1766               Hash (Src_Node.Element) mod Buckets'Length;
1767
1768             Tgt_Node : Node_Access := Buckets (J);
1769
1770          begin
1771             while Tgt_Node /= null loop
1772                if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then
1773                   return;
1774                end if;
1775
1776                Tgt_Node := Next (Tgt_Node);
1777             end loop;
1778
1779             Buckets (J) := new Node_Type'(Src_Node.Element, Buckets (J));
1780             Length := Length + 1;
1781          end Process;
1782
1783          --  Per AI05-0022, the container implementation is required to detect
1784          --  element tampering by a generic actual subprogram, hence the use of
1785          --  Checked_Index instead of a simple invocation of generic formal
1786          --  Hash.
1787
1788          LB : Integer renames Left_HT.Busy;
1789          LL : Integer renames Left_HT.Lock;
1790
1791          RB : Integer renames Right_HT.Busy;
1792          RL : Integer renames Right_HT.Lock;
1793
1794       --  Start of processing for Iterate_Right
1795
1796       begin
1797          LB := LB + 1;
1798          LL := LL + 1;
1799
1800          RB := RB + 1;
1801          RL := RL + 1;
1802
1803          Iterate (Right_HT);
1804
1805          RL := RL - 1;
1806          RB := RB - 1;
1807
1808          LL := LL - 1;
1809          LB := LB - 1;
1810
1811       exception
1812          when others =>
1813             RL := RL - 1;
1814             RB := RB - 1;
1815
1816             LL := LL - 1;
1817             LB := LB - 1;
1818
1819             HT_Ops.Free_Hash_Table (Buckets);
1820             raise;
1821       end Iterate_Right;
1822
1823       return (Controlled with HT => (Buckets, Length, 0, 0));
1824    end Union;
1825
1826    ---------
1827    -- Vet --
1828    ---------
1829
1830    function Vet (Position : Cursor) return Boolean is
1831    begin
1832       if Position.Node = null then
1833          return Position.Container = null;
1834       end if;
1835
1836       if Position.Container = null then
1837          return False;
1838       end if;
1839
1840       if Position.Node.Next = Position.Node then
1841          return False;
1842       end if;
1843
1844       declare
1845          HT : Hash_Table_Type renames Position.Container.HT;
1846          X  : Node_Access;
1847
1848       begin
1849          if HT.Length = 0 then
1850             return False;
1851          end if;
1852
1853          if HT.Buckets = null
1854            or else HT.Buckets'Length = 0
1855          then
1856             return False;
1857          end if;
1858
1859          X := HT.Buckets (Element_Keys.Checked_Index
1860                             (HT,
1861                              Position.Node.Element));
1862
1863          for J in 1 .. HT.Length loop
1864             if X = Position.Node then
1865                return True;
1866             end if;
1867
1868             if X = null then
1869                return False;
1870             end if;
1871
1872             if X = X.Next then  --  to prevent unnecessary looping
1873                return False;
1874             end if;
1875
1876             X := X.Next;
1877          end loop;
1878
1879          return False;
1880       end;
1881    end Vet;
1882
1883    -----------
1884    -- Write --
1885    -----------
1886
1887    procedure Write
1888      (Stream    : not null access Root_Stream_Type'Class;
1889       Container : Set)
1890    is
1891    begin
1892       Write_Nodes (Stream, Container.HT);
1893    end Write;
1894
1895    procedure Write
1896      (Stream : not null access Root_Stream_Type'Class;
1897       Item   : Cursor)
1898    is
1899    begin
1900       raise Program_Error with "attempt to stream set cursor";
1901    end Write;
1902
1903    procedure Write
1904      (Stream : not null access Root_Stream_Type'Class;
1905       Item   : Constant_Reference_Type)
1906    is
1907    begin
1908       raise Program_Error with "attempt to stream reference";
1909    end Write;
1910
1911    ----------------
1912    -- Write_Node --
1913    ----------------
1914
1915    procedure Write_Node
1916      (Stream : not null access Root_Stream_Type'Class;
1917       Node   : Node_Access)
1918    is
1919    begin
1920       Element_Type'Write (Stream, Node.Element);
1921    end Write_Node;
1922
1923    package body Generic_Keys is
1924
1925       -----------------------
1926       -- Local Subprograms --
1927       -----------------------
1928
1929       ------------
1930       -- Adjust --
1931       ------------
1932
1933       procedure Adjust (Control : in out Reference_Control_Type) is
1934       begin
1935          if Control.Container /= null then
1936             declare
1937                HT : Hash_Table_Type renames Control.Container.all.HT;
1938                B : Natural renames HT.Busy;
1939                L : Natural renames HT.Lock;
1940             begin
1941                B := B + 1;
1942                L := L + 1;
1943             end;
1944          end if;
1945       end Adjust;
1946
1947       function Equivalent_Key_Node
1948         (Key  : Key_Type;
1949          Node : Node_Access) return Boolean;
1950       pragma Inline (Equivalent_Key_Node);
1951
1952       --------------------------
1953       -- Local Instantiations --
1954       --------------------------
1955
1956       package Key_Keys is
1957          new Hash_Tables.Generic_Keys
1958           (HT_Types  => HT_Types,
1959            Next      => Next,
1960            Set_Next  => Set_Next,
1961            Key_Type  => Key_Type,
1962            Hash      => Hash,
1963            Equivalent_Keys => Equivalent_Key_Node);
1964
1965       ------------------------
1966       -- Constant_Reference --
1967       ------------------------
1968
1969       function Constant_Reference
1970         (Container : aliased Set;
1971          Key       : Key_Type) return Constant_Reference_Type
1972       is
1973          HT   : Hash_Table_Type renames Container'Unrestricted_Access.HT;
1974          Node : constant Node_Access := Key_Keys.Find (HT, Key);
1975
1976       begin
1977          if Node = null then
1978             raise Constraint_Error with "Key not in set";
1979          end if;
1980
1981          declare
1982             B : Natural renames HT.Busy;
1983             L : Natural renames HT.Lock;
1984          begin
1985             return R : constant Constant_Reference_Type :=
1986               (Element => Node.Element'Access,
1987                Control => (Controlled with Container'Unrestricted_Access))
1988             do
1989                B := B + 1;
1990                L := L + 1;
1991             end return;
1992          end;
1993       end Constant_Reference;
1994
1995       --------------
1996       -- Contains --
1997       --------------
1998
1999       function Contains
2000         (Container : Set;
2001          Key       : Key_Type) return Boolean
2002       is
2003       begin
2004          return Find (Container, Key) /= No_Element;
2005       end Contains;
2006
2007       ------------
2008       -- Delete --
2009       ------------
2010
2011       procedure Delete
2012         (Container : in out Set;
2013          Key       : Key_Type)
2014       is
2015          X : Node_Access;
2016
2017       begin
2018          Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
2019
2020          if X = null then
2021             raise Constraint_Error with "attempt to delete key not in set";
2022          end if;
2023
2024          Free (X);
2025       end Delete;
2026
2027       -------------
2028       -- Element --
2029       -------------
2030
2031       function Element
2032         (Container : Set;
2033          Key       : Key_Type) return Element_Type
2034       is
2035          HT   : Hash_Table_Type renames Container'Unrestricted_Access.HT;
2036          Node : constant Node_Access := Key_Keys.Find (HT, Key);
2037
2038       begin
2039          if Node = null then
2040             raise Constraint_Error with "key not in set";
2041          end if;
2042
2043          return Node.Element;
2044       end Element;
2045
2046       -------------------------
2047       -- Equivalent_Key_Node --
2048       -------------------------
2049
2050       function Equivalent_Key_Node
2051         (Key  : Key_Type;
2052          Node : Node_Access) return Boolean
2053       is
2054       begin
2055          return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
2056       end Equivalent_Key_Node;
2057
2058       -------------
2059       -- Exclude --
2060       -------------
2061
2062       procedure Exclude
2063         (Container : in out Set;
2064          Key       : Key_Type)
2065       is
2066          X : Node_Access;
2067       begin
2068          Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
2069          Free (X);
2070       end Exclude;
2071
2072       --------------
2073       -- Finalize --
2074       --------------
2075
2076       procedure Finalize (Control : in out Reference_Control_Type) is
2077       begin
2078          if Control.Container /= null then
2079             declare
2080                HT : Hash_Table_Type renames Control.Container.all.HT;
2081                B  : Natural renames HT.Busy;
2082                L  : Natural renames HT.Lock;
2083             begin
2084                B := B - 1;
2085                L := L - 1;
2086             end;
2087
2088             if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash
2089             then
2090                HT_Ops.Delete_Node_At_Index
2091                  (Control.Container.HT, Control.Index, Control.Old_Pos.Node);
2092                raise Program_Error with "key not preserved in reference";
2093             end if;
2094
2095             Control.Container := null;
2096          end if;
2097       end Finalize;
2098
2099       ----------
2100       -- Find --
2101       ----------
2102
2103       function Find
2104         (Container : Set;
2105          Key       : Key_Type) return Cursor
2106       is
2107          HT   : Hash_Table_Type renames Container'Unrestricted_Access.HT;
2108          Node : constant Node_Access := Key_Keys.Find (HT, Key);
2109       begin
2110          if Node = null then
2111             return No_Element;
2112          else
2113             return Cursor'(Container'Unrestricted_Access, Node);
2114          end if;
2115       end Find;
2116
2117       ---------
2118       -- Key --
2119       ---------
2120
2121       function Key (Position : Cursor) return Key_Type is
2122       begin
2123          if Position.Node = null then
2124             raise Constraint_Error with
2125               "Position cursor equals No_Element";
2126          end if;
2127
2128          pragma Assert (Vet (Position), "bad cursor in function Key");
2129
2130          return Key (Position.Node.Element);
2131       end Key;
2132
2133       ----------
2134       -- Read --
2135       ----------
2136
2137       procedure Read
2138         (Stream : not null access Root_Stream_Type'Class;
2139          Item   : out Reference_Type)
2140       is
2141       begin
2142          raise Program_Error with "attempt to stream reference";
2143       end Read;
2144
2145       ------------------------------
2146       -- Reference_Preserving_Key --
2147       ------------------------------
2148
2149       function Reference_Preserving_Key
2150         (Container : aliased in out Set;
2151          Position  : Cursor) return Reference_Type
2152       is
2153       begin
2154          if Position.Container = null then
2155             raise Constraint_Error with "Position cursor has no element";
2156          end if;
2157
2158          if Position.Container /= Container'Unrestricted_Access then
2159             raise Program_Error with
2160               "Position cursor designates wrong container";
2161          end if;
2162
2163          pragma Assert
2164            (Vet (Position),
2165             "bad cursor in function Reference_Preserving_Key");
2166
2167          declare
2168             HT : Hash_Table_Type renames Position.Container.all.HT;
2169             B  : Natural renames HT.Busy;
2170             L  : Natural renames HT.Lock;
2171          begin
2172             return R : constant Reference_Type :=
2173                          (Element => Position.Node.Element'Access,
2174                           Control =>
2175                             (Controlled with
2176                               Container'Unrestricted_Access,
2177                               Index    => HT_Ops.Index (HT, Position.Node),
2178                               Old_Pos  => Position,
2179                               Old_Hash => Hash (Key (Position))))
2180             do
2181                B := B + 1;
2182                L := L + 1;
2183             end return;
2184          end;
2185       end Reference_Preserving_Key;
2186
2187       function Reference_Preserving_Key
2188         (Container : aliased in out Set;
2189          Key       : Key_Type) return Reference_Type
2190       is
2191          Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2192
2193       begin
2194          if Node = null then
2195             raise Constraint_Error with "key not in set";
2196          end if;
2197
2198          declare
2199             HT : Hash_Table_Type renames Container.HT;
2200             B  : Natural renames HT.Busy;
2201             L  : Natural renames HT.Lock;
2202             P  : constant Cursor := Find (Container, Key);
2203          begin
2204             return R : constant Reference_Type :=
2205                          (Element => Node.Element'Access,
2206                           Control =>
2207                             (Controlled with
2208                               Container'Unrestricted_Access,
2209                               Index    => HT_Ops.Index (HT, P.Node),
2210                               Old_Pos  => P,
2211                               Old_Hash => Hash (Key)))
2212             do
2213                B := B + 1;
2214                L := L + 1;
2215             end return;
2216          end;
2217       end Reference_Preserving_Key;
2218
2219       -------------
2220       -- Replace --
2221       -------------
2222
2223       procedure Replace
2224         (Container : in out Set;
2225          Key       : Key_Type;
2226          New_Item  : Element_Type)
2227       is
2228          Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2229
2230       begin
2231          if Node = null then
2232             raise Constraint_Error with
2233               "attempt to replace key not in set";
2234          end if;
2235
2236          Replace_Element (Container.HT, Node, New_Item);
2237       end Replace;
2238
2239       -----------------------------------
2240       -- Update_Element_Preserving_Key --
2241       -----------------------------------
2242
2243       procedure Update_Element_Preserving_Key
2244         (Container : in out Set;
2245          Position  : Cursor;
2246          Process   : not null access
2247                        procedure (Element : in out Element_Type))
2248       is
2249          HT   : Hash_Table_Type renames Container.HT;
2250          Indx : Hash_Type;
2251
2252       begin
2253          if Position.Node = null then
2254             raise Constraint_Error with
2255               "Position cursor equals No_Element";
2256          end if;
2257
2258          if Position.Container /= Container'Unrestricted_Access then
2259             raise Program_Error with
2260               "Position cursor designates wrong set";
2261          end if;
2262
2263          if HT.Buckets = null
2264            or else HT.Buckets'Length = 0
2265            or else HT.Length = 0
2266            or else Position.Node.Next = Position.Node
2267          then
2268             raise Program_Error with "Position cursor is bad (set is empty)";
2269          end if;
2270
2271          pragma Assert
2272            (Vet (Position),
2273             "bad cursor in Update_Element_Preserving_Key");
2274
2275          --  Per AI05-0022, the container implementation is required to detect
2276          --  element tampering by a generic actual subprogram.
2277
2278          declare
2279             E : Element_Type renames Position.Node.Element;
2280             K : constant Key_Type := Key (E);
2281
2282             B : Natural renames HT.Busy;
2283             L : Natural renames HT.Lock;
2284
2285             Eq : Boolean;
2286
2287          begin
2288             B := B + 1;
2289             L := L + 1;
2290
2291             begin
2292                Indx := HT_Ops.Index (HT, Position.Node);
2293                Process (E);
2294                Eq := Equivalent_Keys (K, Key (E));
2295             exception
2296                when others =>
2297                   L := L - 1;
2298                   B := B - 1;
2299                   raise;
2300             end;
2301
2302             L := L - 1;
2303             B := B - 1;
2304
2305             if Eq then
2306                return;
2307             end if;
2308          end;
2309
2310          if HT.Buckets (Indx) = Position.Node then
2311             HT.Buckets (Indx) := Position.Node.Next;
2312
2313          else
2314             declare
2315                Prev : Node_Access := HT.Buckets (Indx);
2316
2317             begin
2318                while Prev.Next /= Position.Node loop
2319                   Prev := Prev.Next;
2320
2321                   if Prev = null then
2322                      raise Program_Error with
2323                        "Position cursor is bad (node not found)";
2324                   end if;
2325                end loop;
2326
2327                Prev.Next := Position.Node.Next;
2328             end;
2329          end if;
2330
2331          HT.Length := HT.Length - 1;
2332
2333          declare
2334             X : Node_Access := Position.Node;
2335
2336          begin
2337             Free (X);
2338          end;
2339
2340          raise Program_Error with "key was modified";
2341       end Update_Element_Preserving_Key;
2342
2343       -----------
2344       -- Write --
2345       -----------
2346
2347       procedure Write
2348         (Stream : not null access Root_Stream_Type'Class;
2349          Item   : Reference_Type)
2350       is
2351       begin
2352          raise Program_Error with "attempt to stream reference";
2353       end Write;
2354
2355    end Generic_Keys;
2356
2357 end Ada.Containers.Hashed_Sets;