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