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