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