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