gcc/ada/a-ciorse.adb

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