gcc/ada/a-coormu.adb

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