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