gcc/ada/a-ciorse.adb

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