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