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