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