gcc/ada/a-coorse.adb

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