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