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