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