gcc/ada/libgnat/a-cbhase.adb

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