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