gcc/ada/libgnat/a-cihase.adb

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