gcc/ada/a-coorse.adb

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