gcc/ada/a-cohase.adb

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