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