gcc/ada/a-ciormu.adb

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