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