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