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