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