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-2012, 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 := Key_Keys.Find (Container.Tree, Key);
 750       begin
 751          if Node = null then
 752             raise Constraint_Error with "key not in set";
 753          end if;
 754
 755          return Node.Element;
 756       end Element;
 757
 758       ---------------------
 759       -- Equivalent_Keys --
 760       ---------------------
 761
 762       function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
 763       begin
 764          if Left < Right
 765            or else Right < Left
 766          then
 767             return False;
 768          else
 769             return True;
 770          end if;
 771       end Equivalent_Keys;
 772
 773       -------------
 774       -- Exclude --
 775       -------------
 776
 777       procedure Exclude (Container : in out Set; Key : Key_Type) is
 778          Tree : Tree_Type renames Container.Tree;
 779          Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
 780          Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
 781          X    : Node_Access;
 782
 783       begin
 784          while Node /= Done loop
 785             X := Node;
 786             Node := Tree_Operations.Next (Node);
 787             Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 788             Free (X);
 789          end loop;
 790       end Exclude;
 791
 792       ----------
 793       -- Find --
 794       ----------
 795
 796       function Find (Container : Set; Key : Key_Type) return Cursor is
 797          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 798
 799       begin
 800          if Node = null then
 801             return No_Element;
 802          end if;
 803
 804          return Cursor'(Container'Unrestricted_Access, Node);
 805       end Find;
 806
 807       -----------
 808       -- Floor --
 809       -----------
 810
 811       function Floor (Container : Set; Key : Key_Type) return Cursor is
 812          Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
 813
 814       begin
 815          if Node = null then
 816             return No_Element;
 817          end if;
 818
 819          return Cursor'(Container'Unrestricted_Access, Node);
 820       end Floor;
 821
 822       -------------------------
 823       -- Is_Greater_Key_Node --
 824       -------------------------
 825
 826       function Is_Greater_Key_Node
 827         (Left  : Key_Type;
 828          Right : Node_Access) return Boolean is
 829       begin
 830          return Key (Right.Element) < Left;
 831       end Is_Greater_Key_Node;
 832
 833       ----------------------
 834       -- Is_Less_Key_Node --
 835       ----------------------
 836
 837       function Is_Less_Key_Node
 838         (Left  : Key_Type;
 839          Right : Node_Access) return Boolean is
 840       begin
 841          return Left < Key (Right.Element);
 842       end Is_Less_Key_Node;
 843
 844       -------------
 845       -- Iterate --
 846       -------------
 847
 848       procedure Iterate
 849         (Container : Set;
 850          Key       : Key_Type;
 851          Process   : not null access procedure (Position : Cursor))
 852       is
 853          procedure Process_Node (Node : Node_Access);
 854          pragma Inline (Process_Node);
 855
 856          procedure Local_Iterate is
 857            new Key_Keys.Generic_Iteration (Process_Node);
 858
 859          ------------------
 860          -- Process_Node --
 861          ------------------
 862
 863          procedure Process_Node (Node : Node_Access) is
 864          begin
 865             Process (Cursor'(Container'Unrestricted_Access, Node));
 866          end Process_Node;
 867
 868          T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
 869          B : Natural renames T.Busy;
 870
 871       --  Start of processing for Iterate
 872
 873       begin
 874          B := B + 1;
 875
 876          begin
 877             Local_Iterate (T, Key);
 878          exception
 879             when others =>
 880                B := B - 1;
 881                raise;
 882          end;
 883
 884          B := B - 1;
 885       end Iterate;
 886
 887       ---------
 888       -- Key --
 889       ---------
 890
 891       function Key (Position : Cursor) return Key_Type is
 892       begin
 893          if Position.Node = null then
 894             raise Constraint_Error with
 895               "Position cursor equals No_Element";
 896          end if;
 897
 898          pragma Assert (Vet (Position.Container.Tree, Position.Node),
 899                         "bad cursor in Key");
 900
 901          return Key (Position.Node.Element);
 902       end Key;
 903
 904       ---------------------
 905       -- Reverse_Iterate --
 906       ---------------------
 907
 908       procedure Reverse_Iterate
 909         (Container : Set;
 910          Key       : Key_Type;
 911          Process   : not null access procedure (Position : Cursor))
 912       is
 913          procedure Process_Node (Node : Node_Access);
 914          pragma Inline (Process_Node);
 915
 916          procedure Local_Reverse_Iterate is
 917            new Key_Keys.Generic_Reverse_Iteration (Process_Node);
 918
 919          ------------------
 920          -- Process_Node --
 921          ------------------
 922
 923          procedure Process_Node (Node : Node_Access) is
 924          begin
 925             Process (Cursor'(Container'Unrestricted_Access, Node));
 926          end Process_Node;
 927
 928          T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
 929          B : Natural renames T.Busy;
 930
 931       --  Start of processing for Reverse_Iterate
 932
 933       begin
 934          B := B + 1;
 935
 936          begin
 937             Local_Reverse_Iterate (T, Key);
 938          exception
 939             when others =>
 940                B := B - 1;
 941                raise;
 942          end;
 943
 944          B := B - 1;
 945       end Reverse_Iterate;
 946
 947       --------------------
 948       -- Update_Element --
 949       --------------------
 950
 951       procedure Update_Element
 952         (Container : in out Set;
 953          Position  : Cursor;
 954          Process   : not null access procedure (Element : in out Element_Type))
 955       is
 956          Tree : Tree_Type renames Container.Tree;
 957          Node : constant Node_Access := Position.Node;
 958
 959       begin
 960          if Node = null then
 961             raise Constraint_Error with
 962               "Position cursor equals No_Element";
 963          end if;
 964
 965          if Position.Container /= Container'Unrestricted_Access then
 966             raise Program_Error with
 967               "Position cursor designates wrong set";
 968          end if;
 969
 970          pragma Assert (Vet (Tree, Node),
 971                         "bad cursor in Update_Element");
 972
 973          declare
 974             E : Element_Type renames Node.Element;
 975             K : constant Key_Type := Key (E);
 976
 977             B : Natural renames Tree.Busy;
 978             L : Natural renames Tree.Lock;
 979
 980          begin
 981             B := B + 1;
 982             L := L + 1;
 983
 984             begin
 985                Process (E);
 986             exception
 987                when others =>
 988                   L := L - 1;
 989                   B := B - 1;
 990                   raise;
 991             end;
 992
 993             L := L - 1;
 994             B := B - 1;
 995
 996             if Equivalent_Keys (Left => K, Right => Key (E)) then
 997                return;
 998             end if;
 999          end;
1000
1001          --  Delete_Node checks busy-bit
1002
1003          Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
1004
1005          Insert_New_Item : declare
1006             function New_Node return Node_Access;
1007             pragma Inline (New_Node);
1008
1009             procedure Insert_Post is
1010                new Element_Keys.Generic_Insert_Post (New_Node);
1011
1012             procedure Unconditional_Insert is
1013                new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1014
1015             --------------
1016             -- New_Node --
1017             --------------
1018
1019             function New_Node return Node_Access is
1020             begin
1021                Node.Color := Red_Black_Trees.Red;
1022                Node.Parent := null;
1023                Node.Left := null;
1024                Node.Right := null;
1025
1026                return Node;
1027             end New_Node;
1028
1029             Result : Node_Access;
1030
1031          --  Start of processing for Insert_New_Item
1032
1033          begin
1034             Unconditional_Insert
1035               (Tree => Tree,
1036                Key  => Node.Element,
1037                Node => Result);
1038
1039             pragma Assert (Result = Node);
1040          end Insert_New_Item;
1041       end Update_Element;
1042
1043    end Generic_Keys;
1044
1045    -----------------
1046    -- Has_Element --
1047    -----------------
1048
1049    function Has_Element (Position : Cursor) return Boolean is
1050    begin
1051       return Position /= No_Element;
1052    end Has_Element;
1053
1054    ------------
1055    -- Insert --
1056    ------------
1057
1058    procedure Insert (Container : in out Set; New_Item : Element_Type) is
1059       Position : Cursor;
1060       pragma Unreferenced (Position);
1061    begin
1062       Insert (Container, New_Item, Position);
1063    end Insert;
1064
1065    procedure Insert
1066      (Container : in out Set;
1067       New_Item  : Element_Type;
1068       Position  : out Cursor)
1069    is
1070    begin
1071       Insert_Sans_Hint (Container.Tree, New_Item, Position.Node);
1072       Position.Container := Container'Unrestricted_Access;
1073    end Insert;
1074
1075    ----------------------
1076    -- Insert_Sans_Hint --
1077    ----------------------
1078
1079    procedure Insert_Sans_Hint
1080      (Tree     : in out Tree_Type;
1081       New_Item : Element_Type;
1082       Node     : out Node_Access)
1083    is
1084       function New_Node return Node_Access;
1085       pragma Inline (New_Node);
1086
1087       procedure Insert_Post is
1088         new Element_Keys.Generic_Insert_Post (New_Node);
1089
1090       procedure Unconditional_Insert is
1091         new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1092
1093       --------------
1094       -- New_Node --
1095       --------------
1096
1097       function New_Node return Node_Access is
1098          Node : constant Node_Access :=
1099            new Node_Type'(Parent  => null,
1100                           Left    => null,
1101                           Right   => null,
1102                           Color   => Red_Black_Trees.Red,
1103                           Element => New_Item);
1104       begin
1105          return Node;
1106       end New_Node;
1107
1108    --  Start of processing for Insert_Sans_Hint
1109
1110    begin
1111       Unconditional_Insert (Tree, New_Item, Node);
1112    end Insert_Sans_Hint;
1113
1114    ----------------------
1115    -- Insert_With_Hint --
1116    ----------------------
1117
1118    procedure Insert_With_Hint
1119      (Dst_Tree : in out Tree_Type;
1120       Dst_Hint : Node_Access;
1121       Src_Node : Node_Access;
1122       Dst_Node : out Node_Access)
1123    is
1124       function New_Node return Node_Access;
1125       pragma Inline (New_Node);
1126
1127       procedure Insert_Post is
1128         new Element_Keys.Generic_Insert_Post (New_Node);
1129
1130       procedure Insert_Sans_Hint is
1131         new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1132
1133       procedure Local_Insert_With_Hint is
1134         new Element_Keys.Generic_Unconditional_Insert_With_Hint
1135           (Insert_Post,
1136            Insert_Sans_Hint);
1137
1138       --------------
1139       -- New_Node --
1140       --------------
1141
1142       function New_Node return Node_Access is
1143          Node : constant Node_Access :=
1144            new Node_Type'(Parent  => null,
1145                           Left    => null,
1146                           Right   => null,
1147                           Color   => Red,
1148                           Element => Src_Node.Element);
1149       begin
1150          return Node;
1151       end New_Node;
1152
1153    --  Start of processing for Insert_With_Hint
1154
1155    begin
1156       Local_Insert_With_Hint
1157         (Dst_Tree,
1158          Dst_Hint,
1159          Src_Node.Element,
1160          Dst_Node);
1161    end Insert_With_Hint;
1162
1163    ------------------
1164    -- Intersection --
1165    ------------------
1166
1167    procedure Intersection (Target : in out Set; Source : Set) is
1168    begin
1169       Set_Ops.Intersection (Target.Tree, Source.Tree);
1170    end Intersection;
1171
1172    function Intersection (Left, Right : Set) return Set is
1173       Tree : constant Tree_Type :=
1174         Set_Ops.Intersection (Left.Tree, Right.Tree);
1175    begin
1176       return Set'(Controlled with Tree);
1177    end Intersection;
1178
1179    --------------
1180    -- Is_Empty --
1181    --------------
1182
1183    function Is_Empty (Container : Set) return Boolean is
1184    begin
1185       return Container.Tree.Length = 0;
1186    end Is_Empty;
1187
1188    ------------------------
1189    -- Is_Equal_Node_Node --
1190    ------------------------
1191
1192    function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1193    begin
1194       return L.Element = R.Element;
1195    end Is_Equal_Node_Node;
1196
1197    -----------------------------
1198    -- Is_Greater_Element_Node --
1199    -----------------------------
1200
1201    function Is_Greater_Element_Node
1202      (Left  : Element_Type;
1203       Right : Node_Access) return Boolean
1204    is
1205    begin
1206       --  e > node same as node < e
1207
1208       return Right.Element < Left;
1209    end Is_Greater_Element_Node;
1210
1211    --------------------------
1212    -- Is_Less_Element_Node --
1213    --------------------------
1214
1215    function Is_Less_Element_Node
1216      (Left  : Element_Type;
1217       Right : Node_Access) return Boolean
1218    is
1219    begin
1220       return Left < Right.Element;
1221    end Is_Less_Element_Node;
1222
1223    -----------------------
1224    -- Is_Less_Node_Node --
1225    -----------------------
1226
1227    function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1228    begin
1229       return L.Element < R.Element;
1230    end Is_Less_Node_Node;
1231
1232    ---------------
1233    -- Is_Subset --
1234    ---------------
1235
1236    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1237    begin
1238       return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1239    end Is_Subset;
1240
1241    -------------
1242    -- Iterate --
1243    -------------
1244
1245    procedure Iterate
1246      (Container : Set;
1247       Process   : not null access procedure (Position : Cursor))
1248    is
1249       procedure Process_Node (Node : Node_Access);
1250       pragma Inline (Process_Node);
1251
1252       procedure Local_Iterate is
1253         new Tree_Operations.Generic_Iteration (Process_Node);
1254
1255       ------------------
1256       -- Process_Node --
1257       ------------------
1258
1259       procedure Process_Node (Node : Node_Access) is
1260       begin
1261          Process (Cursor'(Container'Unrestricted_Access, Node));
1262       end Process_Node;
1263
1264       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1265       B : Natural renames T.Busy;
1266
1267    --  Start of processing for Iterate
1268
1269    begin
1270       B := B + 1;
1271
1272       begin
1273          Local_Iterate (T);
1274       exception
1275          when others =>
1276             B := B - 1;
1277             raise;
1278       end;
1279
1280       B := B - 1;
1281    end Iterate;
1282
1283    procedure Iterate
1284      (Container : Set;
1285       Item      : Element_Type;
1286       Process   : not null access procedure (Position : Cursor))
1287    is
1288       procedure Process_Node (Node : Node_Access);
1289       pragma Inline (Process_Node);
1290
1291       procedure Local_Iterate is
1292         new Element_Keys.Generic_Iteration (Process_Node);
1293
1294       ------------------
1295       -- Process_Node --
1296       ------------------
1297
1298       procedure Process_Node (Node : Node_Access) is
1299       begin
1300          Process (Cursor'(Container'Unrestricted_Access, Node));
1301       end Process_Node;
1302
1303       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1304       B : Natural renames T.Busy;
1305
1306    --  Start of processing for Iterate
1307
1308    begin
1309       B := B + 1;
1310
1311       begin
1312          Local_Iterate (T, Item);
1313       exception
1314          when others =>
1315             B := B - 1;
1316             raise;
1317       end;
1318
1319       B := B - 1;
1320    end Iterate;
1321
1322    function Iterate (Container : Set)
1323      return Set_Iterator_Interfaces.Reversible_Iterator'Class
1324    is
1325       S : constant Set_Access := Container'Unrestricted_Access;
1326       B : Natural renames S.Tree.Busy;
1327
1328    begin
1329       --  The value of the Node component influences the behavior of the First
1330       --  and Last selector functions of the iterator object. When the Node
1331       --  component is null (as is the case here), this means the iterator
1332       --  object was constructed without a start expression. This is a complete
1333       --  iterator, meaning that the iteration starts from the (logical)
1334       --  beginning of the sequence of items.
1335
1336       --  Note: For a forward iterator, Container.First is the beginning, and
1337       --  for a reverse iterator, Container.Last is the beginning.
1338
1339       return It : constant Iterator := (Limited_Controlled with S, null) do
1340          B := B + 1;
1341       end return;
1342    end Iterate;
1343
1344    function Iterate (Container : Set; Start : Cursor)
1345      return Set_Iterator_Interfaces.Reversible_Iterator'Class
1346    is
1347       S : constant Set_Access := Container'Unrestricted_Access;
1348       B : Natural renames S.Tree.Busy;
1349
1350    begin
1351       --  It was formerly the case that when Start = No_Element, the partial
1352       --  iterator was defined to behave the same as for a complete iterator,
1353       --  and iterate over the entire sequence of items. However, those
1354       --  semantics were unintuitive and arguably error-prone (it is too easy
1355       --  to accidentally create an endless loop), and so they were changed,
1356       --  per the ARG meeting in Denver on 2011/11. However, there was no
1357       --  consensus about what positive meaning this corner case should have,
1358       --  and so it was decided to simply raise an exception. This does imply,
1359       --  however, that it is not possible to use a partial iterator to specify
1360       --  an empty sequence of items.
1361
1362       if Start = No_Element then
1363          raise Constraint_Error with
1364            "Start position for iterator equals No_Element";
1365       end if;
1366
1367       if Start.Container /= Container'Unrestricted_Access then
1368          raise Program_Error with
1369            "Start cursor of Iterate designates wrong set";
1370       end if;
1371
1372       pragma Assert (Vet (Container.Tree, Start.Node),
1373                      "Start cursor of Iterate is bad");
1374
1375       --  The value of the Node component influences the behavior of the First
1376       --  and Last selector functions of the iterator object. When the Node
1377       --  component is non-null (as is the case here), it means that this is a
1378       --  partial iteration, over a subset of the complete sequence of
1379       --  items. The iterator object was constructed with a start expression,
1380       --  indicating the position from which the iteration begins. Note that
1381       --  the start position has the same value irrespective of whether this is
1382       --  a forward or reverse iteration.
1383
1384       return It : constant Iterator :=
1385         (Limited_Controlled with S, Start.Node)
1386       do
1387          B := B + 1;
1388       end return;
1389    end Iterate;
1390
1391    ----------
1392    -- Last --
1393    ----------
1394
1395    function Last (Container : Set) return Cursor is
1396    begin
1397       if Container.Tree.Last = null then
1398          return No_Element;
1399       end if;
1400
1401       return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
1402    end Last;
1403
1404    function Last (Object : Iterator) return Cursor is
1405    begin
1406       --  The value of the iterator object's Node component influences the
1407       --  behavior of the Last (and First) selector function.
1408
1409       --  When the Node component is null, this means the iterator object was
1410       --  constructed without a start expression, in which case the (reverse)
1411       --  iteration starts from the (logical) beginning of the entire sequence
1412       --  (corresponding to Container.Last, for a reverse iterator).
1413
1414       --  Otherwise, this is iteration over a partial sequence of items. When
1415       --  the Node component is non-null, the iterator object was constructed
1416       --  with a start expression, that specifies the position from which the
1417       --  (reverse) partial iteration begins.
1418
1419       if Object.Node = null then
1420          return Object.Container.Last;
1421       else
1422          return Cursor'(Object.Container, Object.Node);
1423       end if;
1424    end Last;
1425
1426    ------------------
1427    -- Last_Element --
1428    ------------------
1429
1430    function Last_Element (Container : Set) return Element_Type is
1431    begin
1432       if Container.Tree.Last = null then
1433          raise Constraint_Error with "set is empty";
1434       end if;
1435
1436       return Container.Tree.Last.Element;
1437    end Last_Element;
1438
1439    ----------
1440    -- Left --
1441    ----------
1442
1443    function Left (Node : Node_Access) return Node_Access is
1444    begin
1445       return Node.Left;
1446    end Left;
1447
1448    ------------
1449    -- Length --
1450    ------------
1451
1452    function Length (Container : Set) return Count_Type is
1453    begin
1454       return Container.Tree.Length;
1455    end Length;
1456
1457    ----------
1458    -- Move --
1459    ----------
1460
1461    procedure Move is
1462       new Tree_Operations.Generic_Move (Clear);
1463
1464    procedure Move (Target : in out Set; Source : in out Set) is
1465    begin
1466       Move (Target => Target.Tree, Source => Source.Tree);
1467    end Move;
1468
1469    ----------
1470    -- Next --
1471    ----------
1472
1473    procedure Next (Position : in out Cursor)
1474    is
1475    begin
1476       Position := Next (Position);
1477    end Next;
1478
1479    function Next (Position : Cursor) return Cursor is
1480    begin
1481       if Position = No_Element then
1482          return No_Element;
1483       end if;
1484
1485       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1486                      "bad cursor in Next");
1487
1488       declare
1489          Node : constant Node_Access := Tree_Operations.Next (Position.Node);
1490       begin
1491          if Node = null then
1492             return No_Element;
1493          end if;
1494
1495          return Cursor'(Position.Container, Node);
1496       end;
1497    end Next;
1498
1499    function Next (Object : Iterator; Position : Cursor) return Cursor is
1500    begin
1501       if Position.Container = null then
1502          return No_Element;
1503       end if;
1504
1505       if Position.Container /= Object.Container then
1506          raise Program_Error with
1507            "Position cursor of Next designates wrong set";
1508       end if;
1509
1510       return Next (Position);
1511    end Next;
1512
1513    -------------
1514    -- Overlap --
1515    -------------
1516
1517    function Overlap (Left, Right : Set) return Boolean is
1518    begin
1519       return Set_Ops.Overlap (Left.Tree, Right.Tree);
1520    end Overlap;
1521
1522    ------------
1523    -- Parent --
1524    ------------
1525
1526    function Parent (Node : Node_Access) return Node_Access is
1527    begin
1528       return Node.Parent;
1529    end Parent;
1530
1531    --------------
1532    -- Previous --
1533    --------------
1534
1535    procedure Previous (Position : in out Cursor)
1536    is
1537    begin
1538       Position := Previous (Position);
1539    end Previous;
1540
1541    function Previous (Position : Cursor) return Cursor is
1542    begin
1543       if Position = No_Element then
1544          return No_Element;
1545       end if;
1546
1547       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1548                      "bad cursor in Previous");
1549
1550       declare
1551          Node : constant Node_Access :=
1552            Tree_Operations.Previous (Position.Node);
1553       begin
1554          return (if Node = null then No_Element
1555                  else Cursor'(Position.Container, Node));
1556       end;
1557    end Previous;
1558
1559    function Previous (Object : Iterator; Position : Cursor) return Cursor is
1560    begin
1561       if Position.Container = null then
1562          return No_Element;
1563       end if;
1564
1565       if Position.Container /= Object.Container then
1566          raise Program_Error with
1567            "Position cursor of Previous designates wrong set";
1568       end if;
1569
1570       return Previous (Position);
1571    end Previous;
1572
1573    -------------------
1574    -- Query_Element --
1575    -------------------
1576
1577    procedure Query_Element
1578      (Position : Cursor;
1579       Process  : not null access procedure (Element : Element_Type))
1580    is
1581    begin
1582       if Position.Node = null then
1583          raise Constraint_Error with "Position cursor equals No_Element";
1584       end if;
1585
1586       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1587                      "bad cursor in Query_Element");
1588
1589       declare
1590          T : Tree_Type renames Position.Container.Tree;
1591
1592          B : Natural renames T.Busy;
1593          L : Natural renames T.Lock;
1594
1595       begin
1596          B := B + 1;
1597          L := L + 1;
1598
1599          begin
1600             Process (Position.Node.Element);
1601          exception
1602             when others =>
1603                L := L - 1;
1604                B := B - 1;
1605                raise;
1606          end;
1607
1608          L := L - 1;
1609          B := B - 1;
1610       end;
1611    end Query_Element;
1612
1613    ----------
1614    -- Read --
1615    ----------
1616
1617    procedure Read
1618      (Stream    : not null access Root_Stream_Type'Class;
1619       Container : out Set)
1620    is
1621       function Read_Node
1622         (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1623       pragma Inline (Read_Node);
1624
1625       procedure Read is
1626          new Tree_Operations.Generic_Read (Clear, Read_Node);
1627
1628       ---------------
1629       -- Read_Node --
1630       ---------------
1631
1632       function Read_Node
1633         (Stream : not null access Root_Stream_Type'Class) return Node_Access
1634       is
1635          Node : Node_Access := new Node_Type;
1636       begin
1637          Element_Type'Read (Stream, Node.Element);
1638          return Node;
1639       exception
1640          when others =>
1641             Free (Node);  --  Note that Free deallocates elem too
1642             raise;
1643       end Read_Node;
1644
1645    --  Start of processing for Read
1646
1647    begin
1648       Read (Stream, Container.Tree);
1649    end Read;
1650
1651    procedure Read
1652      (Stream : not null access Root_Stream_Type'Class;
1653       Item   : out Cursor)
1654    is
1655    begin
1656       raise Program_Error with "attempt to stream set cursor";
1657    end Read;
1658
1659    ---------------------
1660    -- Replace_Element --
1661    ---------------------
1662
1663    procedure Replace_Element
1664      (Tree : in out Tree_Type;
1665       Node : Node_Access;
1666       Item : Element_Type)
1667    is
1668    begin
1669       if Item < Node.Element
1670         or else Node.Element < Item
1671       then
1672          null;
1673       else
1674          if Tree.Lock > 0 then
1675             raise Program_Error with
1676               "attempt to tamper with elements (set is locked)";
1677          end if;
1678
1679          Node.Element := Item;
1680          return;
1681       end if;
1682
1683       Tree_Operations.Delete_Node_Sans_Free (Tree, Node);  -- Checks busy-bit
1684
1685       Insert_New_Item : declare
1686          function New_Node return Node_Access;
1687          pragma Inline (New_Node);
1688
1689          procedure Insert_Post is
1690             new Element_Keys.Generic_Insert_Post (New_Node);
1691
1692          procedure Unconditional_Insert is
1693             new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1694
1695          --------------
1696          -- New_Node --
1697          --------------
1698
1699          function New_Node return Node_Access is
1700          begin
1701             Node.Element := Item;
1702             Node.Color := Red_Black_Trees.Red;
1703             Node.Parent := null;
1704             Node.Left := null;
1705             Node.Right := null;
1706
1707             return Node;
1708          end New_Node;
1709
1710          Result : Node_Access;
1711
1712       --  Start of processing for Insert_New_Item
1713
1714       begin
1715          Unconditional_Insert
1716            (Tree => Tree,
1717             Key  => Item,
1718             Node => Result);
1719
1720          pragma Assert (Result = Node);
1721       end Insert_New_Item;
1722    end Replace_Element;
1723
1724    procedure Replace_Element
1725      (Container : in out Set;
1726       Position  : Cursor;
1727       New_Item  : Element_Type)
1728    is
1729    begin
1730       if Position.Node = null then
1731          raise Constraint_Error with
1732            "Position cursor equals No_Element";
1733       end if;
1734
1735       if Position.Container /= Container'Unrestricted_Access then
1736          raise Program_Error with
1737            "Position cursor designates wrong set";
1738       end if;
1739
1740       pragma Assert (Vet (Container.Tree, Position.Node),
1741                      "bad cursor in Replace_Element");
1742
1743       Replace_Element (Container.Tree, Position.Node, New_Item);
1744    end Replace_Element;
1745
1746    ---------------------
1747    -- Reverse_Iterate --
1748    ---------------------
1749
1750    procedure Reverse_Iterate
1751      (Container : Set;
1752       Process   : not null access procedure (Position : Cursor))
1753    is
1754       procedure Process_Node (Node : Node_Access);
1755       pragma Inline (Process_Node);
1756
1757       procedure Local_Reverse_Iterate is
1758         new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1759
1760       ------------------
1761       -- Process_Node --
1762       ------------------
1763
1764       procedure Process_Node (Node : Node_Access) is
1765       begin
1766          Process (Cursor'(Container'Unrestricted_Access, Node));
1767       end Process_Node;
1768
1769       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1770       B : Natural renames T.Busy;
1771
1772    --  Start of processing for Reverse_Iterate
1773
1774    begin
1775       B := B + 1;
1776
1777       begin
1778          Local_Reverse_Iterate (T);
1779       exception
1780          when others =>
1781             B := B - 1;
1782             raise;
1783       end;
1784
1785       B := B - 1;
1786    end Reverse_Iterate;
1787
1788    procedure Reverse_Iterate
1789      (Container : Set;
1790       Item      : Element_Type;
1791       Process   : not null access procedure (Position : Cursor))
1792    is
1793       procedure Process_Node (Node : Node_Access);
1794       pragma Inline (Process_Node);
1795
1796       procedure Local_Reverse_Iterate is
1797          new Element_Keys.Generic_Reverse_Iteration (Process_Node);
1798
1799       ------------------
1800       -- Process_Node --
1801       ------------------
1802
1803       procedure Process_Node (Node : Node_Access) is
1804       begin
1805          Process (Cursor'(Container'Unrestricted_Access, Node));
1806       end Process_Node;
1807
1808       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1809       B : Natural renames T.Busy;
1810
1811    --  Start of processing for Reverse_Iterate
1812
1813    begin
1814       B := B + 1;
1815
1816       begin
1817          Local_Reverse_Iterate (T, Item);
1818       exception
1819          when others =>
1820             B := B - 1;
1821             raise;
1822       end;
1823
1824       B := B - 1;
1825    end Reverse_Iterate;
1826
1827    -----------
1828    -- Right --
1829    -----------
1830
1831    function Right (Node : Node_Access) return Node_Access is
1832    begin
1833       return Node.Right;
1834    end Right;
1835
1836    ---------------
1837    -- Set_Color --
1838    ---------------
1839
1840    procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1841    begin
1842       Node.Color := Color;
1843    end Set_Color;
1844
1845    --------------
1846    -- Set_Left --
1847    --------------
1848
1849    procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1850    begin
1851       Node.Left := Left;
1852    end Set_Left;
1853
1854    ----------------
1855    -- Set_Parent --
1856    ----------------
1857
1858    procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1859    begin
1860       Node.Parent := Parent;
1861    end Set_Parent;
1862
1863    ---------------
1864    -- Set_Right --
1865    ---------------
1866
1867    procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1868    begin
1869       Node.Right := Right;
1870    end Set_Right;
1871
1872    --------------------------
1873    -- Symmetric_Difference --
1874    --------------------------
1875
1876    procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1877    begin
1878       Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1879    end Symmetric_Difference;
1880
1881    function Symmetric_Difference (Left, Right : Set) return Set is
1882       Tree : constant Tree_Type :=
1883         Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1884    begin
1885       return Set'(Controlled with Tree);
1886    end Symmetric_Difference;
1887
1888    ------------
1889    -- To_Set --
1890    ------------
1891
1892    function To_Set (New_Item : Element_Type) return Set is
1893       Tree : Tree_Type;
1894       Node : Node_Access;
1895       pragma Unreferenced (Node);
1896    begin
1897       Insert_Sans_Hint (Tree, New_Item, Node);
1898       return Set'(Controlled with Tree);
1899    end To_Set;
1900
1901    -----------
1902    -- Union --
1903    -----------
1904
1905    procedure Union (Target : in out Set; Source : Set) is
1906    begin
1907       Set_Ops.Union (Target.Tree, Source.Tree);
1908    end Union;
1909
1910    function Union (Left, Right : Set) return Set is
1911       Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree);
1912    begin
1913       return Set'(Controlled with Tree);
1914    end Union;
1915
1916    -----------
1917    -- Write --
1918    -----------
1919
1920    procedure Write
1921      (Stream    : not null access Root_Stream_Type'Class;
1922       Container : Set)
1923    is
1924       procedure Write_Node
1925         (Stream : not null access Root_Stream_Type'Class;
1926          Node   : Node_Access);
1927       pragma Inline (Write_Node);
1928
1929       procedure Write is
1930          new Tree_Operations.Generic_Write (Write_Node);
1931
1932       ----------------
1933       -- Write_Node --
1934       ----------------
1935
1936       procedure Write_Node
1937         (Stream : not null access Root_Stream_Type'Class;
1938          Node   : Node_Access)
1939       is
1940       begin
1941          Element_Type'Write (Stream, Node.Element);
1942       end Write_Node;
1943
1944    --  Start of processing for Write
1945
1946    begin
1947       Write (Stream, Container.Tree);
1948    end Write;
1949
1950    procedure Write
1951      (Stream : not null access Root_Stream_Type'Class;
1952       Item   : Cursor)
1953    is
1954    begin
1955       raise Program_Error with "attempt to stream set cursor";
1956    end Write;
1957
1958 end Ada.Containers.Ordered_Multisets;