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