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-2009, 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 package body Ada.Containers.Indefinite_Ordered_Sets is
  42
  43    -----------------------
  44    -- Local Subprograms --
  45    -----------------------
  46
  47    function Color (Node : Node_Access) return Color_Type;
  48    pragma Inline (Color);
  49
  50    function Copy_Node (Source : Node_Access) return Node_Access;
  51    pragma Inline (Copy_Node);
  52
  53    procedure Free (X : in out Node_Access);
  54
  55    procedure Insert_Sans_Hint
  56      (Tree     : in out Tree_Type;
  57       New_Item : Element_Type;
  58       Node     : out Node_Access;
  59       Inserted : out Boolean);
  60
  61    procedure Insert_With_Hint
  62      (Dst_Tree : in out Tree_Type;
  63       Dst_Hint : Node_Access;
  64       Src_Node : Node_Access;
  65       Dst_Node : out Node_Access);
  66
  67    function Is_Greater_Element_Node
  68      (Left  : Element_Type;
  69       Right : Node_Access) return Boolean;
  70    pragma Inline (Is_Greater_Element_Node);
  71
  72    function Is_Less_Element_Node
  73      (Left  : Element_Type;
  74       Right : Node_Access) return Boolean;
  75    pragma Inline (Is_Less_Element_Node);
  76
  77    function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
  78    pragma Inline (Is_Less_Node_Node);
  79
  80    function Left (Node : Node_Access) return Node_Access;
  81    pragma Inline (Left);
  82
  83    function Parent (Node : Node_Access) return Node_Access;
  84    pragma Inline (Parent);
  85
  86    procedure Replace_Element
  87      (Tree : in out Tree_Type;
  88       Node : Node_Access;
  89       Item : Element_Type);
  90
  91    function Right (Node : Node_Access) return Node_Access;
  92    pragma Inline (Right);
  93
  94    procedure Set_Color (Node : Node_Access; Color : Color_Type);
  95    pragma Inline (Set_Color);
  96
  97    procedure Set_Left (Node : Node_Access; Left : Node_Access);
  98    pragma Inline (Set_Left);
  99
 100    procedure Set_Parent (Node   : Node_Access; Parent : Node_Access);
 101    pragma Inline (Set_Parent);
 102
 103    procedure Set_Right (Node : Node_Access; Right : Node_Access);
 104    pragma Inline (Set_Right);
 105
 106    --------------------------
 107    -- Local Instantiations --
 108    --------------------------
 109
 110    procedure Free_Element is
 111      new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
 112
 113    package Tree_Operations is
 114      new Red_Black_Trees.Generic_Operations (Tree_Types);
 115
 116    procedure Delete_Tree is
 117      new Tree_Operations.Generic_Delete_Tree (Free);
 118
 119    function Copy_Tree is
 120      new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
 121
 122    use Tree_Operations;
 123
 124    package Element_Keys is
 125      new Red_Black_Trees.Generic_Keys
 126        (Tree_Operations     => Tree_Operations,
 127         Key_Type            => Element_Type,
 128         Is_Less_Key_Node    => Is_Less_Element_Node,
 129         Is_Greater_Key_Node => Is_Greater_Element_Node);
 130
 131    package Set_Ops is
 132       new Generic_Set_Operations
 133         (Tree_Operations  => Tree_Operations,
 134          Insert_With_Hint => Insert_With_Hint,
 135          Copy_Tree        => Copy_Tree,
 136          Delete_Tree      => Delete_Tree,
 137          Is_Less          => Is_Less_Node_Node,
 138          Free             => Free);
 139
 140    ---------
 141    -- "<" --
 142    ---------
 143
 144    function "<" (Left, Right : Cursor) return Boolean is
 145    begin
 146       if Left.Node = null then
 147          raise Constraint_Error with "Left cursor equals No_Element";
 148       end if;
 149
 150       if Right.Node = null then
 151          raise Constraint_Error with "Right cursor equals No_Element";
 152       end if;
 153
 154       if Left.Node.Element = null then
 155          raise Program_Error with "Left cursor is bad";
 156       end if;
 157
 158       if Right.Node.Element = null then
 159          raise Program_Error with "Right cursor is bad";
 160       end if;
 161
 162       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 163                      "bad Left cursor in ""<""");
 164
 165       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 166                      "bad Right cursor in ""<""");
 167
 168       return Left.Node.Element.all < Right.Node.Element.all;
 169    end "<";
 170
 171    function "<" (Left : Cursor; Right : Element_Type) return Boolean is
 172    begin
 173       if Left.Node = null then
 174          raise Constraint_Error with "Left cursor equals No_Element";
 175       end if;
 176
 177       if Left.Node.Element = null then
 178          raise Program_Error with "Left cursor is bad";
 179       end if;
 180
 181       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 182                      "bad Left cursor in ""<""");
 183
 184       return Left.Node.Element.all < Right;
 185    end "<";
 186
 187    function "<" (Left : Element_Type; Right : Cursor) return Boolean is
 188    begin
 189       if Right.Node = null then
 190          raise Constraint_Error with "Right cursor equals No_Element";
 191       end if;
 192
 193       if Right.Node.Element = null then
 194          raise Program_Error with "Right cursor is bad";
 195       end if;
 196
 197       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 198                      "bad Right cursor in ""<""");
 199
 200       return Left < Right.Node.Element.all;
 201    end "<";
 202
 203    ---------
 204    -- "=" --
 205    ---------
 206
 207    function "=" (Left, Right : Set) return Boolean is
 208
 209       function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
 210       pragma Inline (Is_Equal_Node_Node);
 211
 212       function Is_Equal is
 213         new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
 214
 215       ------------------------
 216       -- Is_Equal_Node_Node --
 217       ------------------------
 218
 219       function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
 220       begin
 221          return L.Element.all = R.Element.all;
 222       end Is_Equal_Node_Node;
 223
 224    --  Start of processing for "="
 225
 226    begin
 227       return Is_Equal (Left.Tree, Right.Tree);
 228    end "=";
 229
 230    ---------
 231    -- ">" --
 232    ---------
 233
 234    function ">" (Left, Right : Cursor) return Boolean is
 235    begin
 236       if Left.Node = null then
 237          raise Constraint_Error with "Left cursor equals No_Element";
 238       end if;
 239
 240       if Right.Node = null then
 241          raise Constraint_Error with "Right cursor equals No_Element";
 242       end if;
 243
 244       if Left.Node.Element = null then
 245          raise Program_Error with "Left cursor is bad";
 246       end if;
 247
 248       if Right.Node.Element = null then
 249          raise Program_Error with "Right cursor is bad";
 250       end if;
 251
 252       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 253                      "bad Left cursor in "">""");
 254
 255       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 256                      "bad Right cursor in "">""");
 257
 258       --  L > R same as R < L
 259
 260       return Right.Node.Element.all < Left.Node.Element.all;
 261    end ">";
 262
 263    function ">" (Left : Cursor; Right : Element_Type) return Boolean is
 264    begin
 265       if Left.Node = null then
 266          raise Constraint_Error with "Left cursor equals No_Element";
 267       end if;
 268
 269       if Left.Node.Element = null then
 270          raise Program_Error with "Left cursor is bad";
 271       end if;
 272
 273       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 274                      "bad Left cursor in "">""");
 275
 276       return Right < Left.Node.Element.all;
 277    end ">";
 278
 279    function ">" (Left : Element_Type; Right : Cursor) return Boolean is
 280    begin
 281       if Right.Node = null then
 282          raise Constraint_Error with "Right cursor equals No_Element";
 283       end if;
 284
 285       if Right.Node.Element = null then
 286          raise Program_Error with "Right cursor is bad";
 287       end if;
 288
 289       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 290                      "bad Right cursor in "">""");
 291
 292       return Right.Node.Element.all < Left;
 293    end ">";
 294
 295    ------------
 296    -- Adjust --
 297    ------------
 298
 299    procedure Adjust is
 300       new Tree_Operations.Generic_Adjust (Copy_Tree);
 301
 302    procedure Adjust (Container : in out Set) is
 303    begin
 304       Adjust (Container.Tree);
 305    end Adjust;
 306
 307    -------------
 308    -- Ceiling --
 309    -------------
 310
 311    function Ceiling (Container : Set; Item : Element_Type) return Cursor is
 312       Node : constant Node_Access :=
 313                Element_Keys.Ceiling (Container.Tree, Item);
 314
 315    begin
 316       if Node = null then
 317          return No_Element;
 318       end if;
 319
 320       return Cursor'(Container'Unrestricted_Access, Node);
 321    end Ceiling;
 322
 323    -----------
 324    -- Clear --
 325    -----------
 326
 327    procedure Clear is
 328       new Tree_Operations.Generic_Clear (Delete_Tree);
 329
 330    procedure Clear (Container : in out Set) is
 331    begin
 332       Clear (Container.Tree);
 333    end Clear;
 334
 335    -----------
 336    -- Color --
 337    -----------
 338
 339    function Color (Node : Node_Access) return Color_Type is
 340    begin
 341       return Node.Color;
 342    end Color;
 343
 344    --------------
 345    -- Contains --
 346    --------------
 347
 348    function Contains (Container : Set; Item : Element_Type) return Boolean is
 349    begin
 350       return Find (Container, Item) /= No_Element;
 351    end Contains;
 352
 353    ---------------
 354    -- Copy_Node --
 355    ---------------
 356
 357    function Copy_Node (Source : Node_Access) return Node_Access is
 358       Element : Element_Access := new Element_Type'(Source.Element.all);
 359
 360    begin
 361       return new Node_Type'(Parent  => null,
 362                             Left    => null,
 363                             Right   => null,
 364                             Color   => Source.Color,
 365                             Element => Element);
 366    exception
 367       when others =>
 368          Free_Element (Element);
 369          raise;
 370    end Copy_Node;
 371
 372    ------------
 373    -- Delete --
 374    ------------
 375
 376    procedure Delete (Container : in out Set; Position : in out Cursor) is
 377    begin
 378       if Position.Node = null then
 379          raise Constraint_Error with "Position cursor equals No_Element";
 380       end if;
 381
 382       if Position.Node.Element = null then
 383          raise Program_Error with "Position cursor is bad";
 384       end if;
 385
 386       if Position.Container /= Container'Unrestricted_Access then
 387          raise Program_Error with "Position cursor designates wrong set";
 388       end if;
 389
 390       pragma Assert (Vet (Container.Tree, Position.Node),
 391                      "bad cursor in Delete");
 392
 393       Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
 394       Free (Position.Node);
 395       Position.Container := null;
 396    end Delete;
 397
 398    procedure Delete (Container : in out Set; Item : Element_Type) is
 399       X : Node_Access :=
 400             Element_Keys.Find (Container.Tree, Item);
 401
 402    begin
 403       if X = null then
 404          raise Constraint_Error with "attempt to delete element not in set";
 405       end if;
 406
 407       Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 408       Free (X);
 409    end Delete;
 410
 411    ------------------
 412    -- Delete_First --
 413    ------------------
 414
 415    procedure Delete_First (Container : in out Set) is
 416       Tree : Tree_Type renames Container.Tree;
 417       X    : Node_Access := Tree.First;
 418
 419    begin
 420       if X /= null then
 421          Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 422          Free (X);
 423       end if;
 424    end Delete_First;
 425
 426    -----------------
 427    -- Delete_Last --
 428    -----------------
 429
 430    procedure Delete_Last (Container : in out Set) is
 431       Tree : Tree_Type renames Container.Tree;
 432       X    : Node_Access := Tree.Last;
 433
 434    begin
 435       if X /= null then
 436          Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 437          Free (X);
 438       end if;
 439    end Delete_Last;
 440
 441    ----------------
 442    -- Difference --
 443    ----------------
 444
 445    procedure Difference (Target : in out Set; Source : Set) is
 446    begin
 447       Set_Ops.Difference (Target.Tree, Source.Tree);
 448    end Difference;
 449
 450    function Difference (Left, Right : Set) return Set is
 451       Tree : constant Tree_Type :=
 452                Set_Ops.Difference (Left.Tree, Right.Tree);
 453    begin
 454       return Set'(Controlled with Tree);
 455    end Difference;
 456
 457    -------------
 458    -- Element --
 459    -------------
 460
 461    function Element (Position : Cursor) return Element_Type is
 462    begin
 463       if Position.Node = null then
 464          raise Constraint_Error with "Position cursor equals No_Element";
 465       end if;
 466
 467       if Position.Node.Element = null then
 468          raise Program_Error with "Position cursor is bad";
 469       end if;
 470
 471       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 472                      "bad cursor in Element");
 473
 474       return Position.Node.Element.all;
 475    end Element;
 476
 477    -------------------------
 478    -- Equivalent_Elements --
 479    -------------------------
 480
 481    function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
 482    begin
 483       if Left < Right
 484         or else Right < Left
 485       then
 486          return False;
 487       else
 488          return True;
 489       end if;
 490    end Equivalent_Elements;
 491
 492    ---------------------
 493    -- Equivalent_Sets --
 494    ---------------------
 495
 496    function Equivalent_Sets (Left, Right : Set) return Boolean is
 497
 498       function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
 499       pragma Inline (Is_Equivalent_Node_Node);
 500
 501       function Is_Equivalent is
 502          new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
 503
 504       -----------------------------
 505       -- Is_Equivalent_Node_Node --
 506       -----------------------------
 507
 508       function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
 509       begin
 510          if L.Element.all < R.Element.all then
 511             return False;
 512          elsif R.Element.all < L.Element.all then
 513             return False;
 514          else
 515             return True;
 516          end if;
 517       end Is_Equivalent_Node_Node;
 518
 519    --  Start of processing for Equivalent_Sets
 520
 521    begin
 522       return Is_Equivalent (Left.Tree, Right.Tree);
 523    end Equivalent_Sets;
 524
 525    -------------
 526    -- Exclude --
 527    -------------
 528
 529    procedure Exclude (Container : in out Set; Item : Element_Type) is
 530       X : Node_Access :=
 531             Element_Keys.Find (Container.Tree, Item);
 532
 533    begin
 534       if X /= null then
 535          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 536          Free (X);
 537       end if;
 538    end Exclude;
 539
 540    ----------
 541    -- Find --
 542    ----------
 543
 544    function Find (Container : Set; Item : Element_Type) return Cursor is
 545       Node : constant Node_Access :=
 546                Element_Keys.Find (Container.Tree, Item);
 547
 548    begin
 549       if Node = null then
 550          return No_Element;
 551       end if;
 552
 553       return Cursor'(Container'Unrestricted_Access, Node);
 554    end Find;
 555
 556    -----------
 557    -- First --
 558    -----------
 559
 560    function First (Container : Set) return Cursor is
 561    begin
 562       if Container.Tree.First = null then
 563          return No_Element;
 564       end if;
 565
 566       return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
 567    end First;
 568
 569    -------------------
 570    -- First_Element --
 571    -------------------
 572
 573    function First_Element (Container : Set) return Element_Type is
 574    begin
 575       if Container.Tree.First = null then
 576          raise Constraint_Error with "set is empty";
 577       end if;
 578
 579       return Container.Tree.First.Element.all;
 580    end First_Element;
 581
 582    -----------
 583    -- Floor --
 584    -----------
 585
 586    function Floor (Container : Set; Item : Element_Type) return Cursor is
 587       Node : constant Node_Access :=
 588                Element_Keys.Floor (Container.Tree, Item);
 589
 590    begin
 591       if Node = null then
 592          return No_Element;
 593       end if;
 594
 595       return Cursor'(Container'Unrestricted_Access, Node);
 596    end Floor;
 597
 598    ----------
 599    -- Free --
 600    ----------
 601
 602    procedure Free (X : in out Node_Access) is
 603       procedure Deallocate is
 604         new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 605
 606    begin
 607       if X = null then
 608          return;
 609       end if;
 610
 611       X.Parent := X;
 612       X.Left := X;
 613       X.Right := X;
 614
 615       begin
 616          Free_Element (X.Element);
 617       exception
 618          when others =>
 619             X.Element := null;
 620             Deallocate (X);
 621             raise;
 622       end;
 623
 624       Deallocate (X);
 625    end Free;
 626
 627    ------------------
 628    -- Generic_Keys --
 629    ------------------
 630
 631    package body Generic_Keys is
 632
 633       -----------------------
 634       -- Local Subprograms --
 635       -----------------------
 636
 637       function Is_Greater_Key_Node
 638         (Left  : Key_Type;
 639          Right : Node_Access) return Boolean;
 640       pragma Inline (Is_Greater_Key_Node);
 641
 642       function Is_Less_Key_Node
 643         (Left  : Key_Type;
 644          Right : Node_Access) return Boolean;
 645       pragma Inline (Is_Less_Key_Node);
 646
 647       --------------------------
 648       -- Local Instantiations --
 649       --------------------------
 650
 651       package Key_Keys is
 652         new Red_Black_Trees.Generic_Keys
 653           (Tree_Operations     => Tree_Operations,
 654            Key_Type            => Key_Type,
 655            Is_Less_Key_Node    => Is_Less_Key_Node,
 656            Is_Greater_Key_Node => Is_Greater_Key_Node);
 657
 658       -------------
 659       -- Ceiling --
 660       -------------
 661
 662       function Ceiling (Container : Set; Key : Key_Type) return Cursor is
 663          Node : constant Node_Access :=
 664                   Key_Keys.Ceiling (Container.Tree, Key);
 665
 666       begin
 667          if Node = null then
 668             return No_Element;
 669          end if;
 670
 671          return Cursor'(Container'Unrestricted_Access, Node);
 672       end Ceiling;
 673
 674       --------------
 675       -- Contains --
 676       --------------
 677
 678       function Contains (Container : Set; Key : Key_Type) return Boolean is
 679       begin
 680          return Find (Container, Key) /= No_Element;
 681       end Contains;
 682
 683       ------------
 684       -- Delete --
 685       ------------
 686
 687       procedure Delete (Container : in out Set; Key : Key_Type) is
 688          X : Node_Access := Key_Keys.Find (Container.Tree, Key);
 689
 690       begin
 691          if X = null then
 692             raise Constraint_Error with "attempt to delete key not in set";
 693          end if;
 694
 695          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 696          Free (X);
 697       end Delete;
 698
 699       -------------
 700       -- Element --
 701       -------------
 702
 703       function Element (Container : Set; Key : Key_Type) return Element_Type is
 704          Node : constant Node_Access :=
 705                   Key_Keys.Find (Container.Tree, Key);
 706
 707       begin
 708          if Node = null then
 709             raise Constraint_Error with "key not in set";
 710          end if;
 711
 712          return Node.Element.all;
 713       end Element;
 714
 715       ---------------------
 716       -- Equivalent_Keys --
 717       ---------------------
 718
 719       function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
 720       begin
 721          if Left < Right
 722            or else Right < Left
 723          then
 724             return False;
 725          else
 726             return True;
 727          end if;
 728       end Equivalent_Keys;
 729
 730       -------------
 731       -- Exclude --
 732       -------------
 733
 734       procedure Exclude (Container : in out Set; Key : Key_Type) is
 735          X : Node_Access := Key_Keys.Find (Container.Tree, Key);
 736
 737       begin
 738          if X /= null then
 739             Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 740             Free (X);
 741          end if;
 742       end Exclude;
 743
 744       ----------
 745       -- Find --
 746       ----------
 747
 748       function Find (Container : Set; Key : Key_Type) return Cursor is
 749          Node : constant Node_Access :=
 750                   Key_Keys.Find (Container.Tree, Key);
 751
 752       begin
 753          if Node = null then
 754             return No_Element;
 755          end if;
 756
 757          return Cursor'(Container'Unrestricted_Access, Node);
 758       end Find;
 759
 760       -----------
 761       -- Floor --
 762       -----------
 763
 764       function Floor (Container : Set; Key : Key_Type) return Cursor is
 765          Node : constant Node_Access :=
 766                   Key_Keys.Floor (Container.Tree, Key);
 767
 768       begin
 769          if Node = null then
 770             return No_Element;
 771          end if;
 772
 773          return Cursor'(Container'Unrestricted_Access, Node);
 774       end Floor;
 775
 776       -------------------------
 777       -- Is_Greater_Key_Node --
 778       -------------------------
 779
 780       function Is_Greater_Key_Node
 781         (Left  : Key_Type;
 782          Right : Node_Access) return Boolean is
 783       begin
 784          return Key (Right.Element.all) < Left;
 785       end Is_Greater_Key_Node;
 786
 787       ----------------------
 788       -- Is_Less_Key_Node --
 789       ----------------------
 790
 791       function Is_Less_Key_Node
 792         (Left  : Key_Type;
 793          Right : Node_Access) return Boolean is
 794       begin
 795          return Left < Key (Right.Element.all);
 796       end Is_Less_Key_Node;
 797
 798       ---------
 799       -- Key --
 800       ---------
 801
 802       function Key (Position : Cursor) return Key_Type is
 803       begin
 804          if Position.Node = null then
 805             raise Constraint_Error with
 806               "Position cursor equals No_Element";
 807          end if;
 808
 809          if Position.Node.Element = null then
 810             raise Program_Error with
 811               "Position cursor is bad";
 812          end if;
 813
 814          pragma Assert (Vet (Position.Container.Tree, Position.Node),
 815                         "bad cursor in Key");
 816
 817          return Key (Position.Node.Element.all);
 818       end Key;
 819
 820       -------------
 821       -- Replace --
 822       -------------
 823
 824       procedure Replace
 825         (Container : in out Set;
 826          Key       : Key_Type;
 827          New_Item  : Element_Type)
 828       is
 829          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 830
 831       begin
 832          if Node = null then
 833             raise Constraint_Error with
 834               "attempt to replace key not in set";
 835          end if;
 836
 837          Replace_Element (Container.Tree, Node, New_Item);
 838       end Replace;
 839
 840       -----------------------------------
 841       -- Update_Element_Preserving_Key --
 842       -----------------------------------
 843
 844       procedure Update_Element_Preserving_Key
 845         (Container : in out Set;
 846          Position  : Cursor;
 847          Process   : not null access
 848                         procedure (Element : in out Element_Type))
 849       is
 850          Tree : Tree_Type renames Container.Tree;
 851
 852       begin
 853          if Position.Node = null then
 854             raise Constraint_Error with "Position cursor equals No_Element";
 855          end if;
 856
 857          if Position.Node.Element = null then
 858             raise Program_Error with "Position cursor is bad";
 859          end if;
 860
 861          if Position.Container /= Container'Unrestricted_Access then
 862             raise Program_Error with "Position cursor designates wrong set";
 863          end if;
 864
 865          pragma Assert (Vet (Container.Tree, Position.Node),
 866                         "bad cursor in Update_Element_Preserving_Key");
 867
 868          declare
 869             E : Element_Type renames Position.Node.Element.all;
 870             K : constant Key_Type := Key (E);
 871
 872             B : Natural renames Tree.Busy;
 873             L : Natural renames Tree.Lock;
 874
 875          begin
 876             B := B + 1;
 877             L := L + 1;
 878
 879             begin
 880                Process (E);
 881             exception
 882                when others =>
 883                   L := L - 1;
 884                   B := B - 1;
 885                   raise;
 886             end;
 887
 888             L := L - 1;
 889             B := B - 1;
 890
 891             if Equivalent_Keys (K, Key (E)) then
 892                return;
 893             end if;
 894          end;
 895
 896          declare
 897             X : Node_Access := Position.Node;
 898          begin
 899             Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 900             Free (X);
 901          end;
 902
 903          raise Program_Error with "key was modified";
 904       end Update_Element_Preserving_Key;
 905
 906    end Generic_Keys;
 907
 908    -----------------
 909    -- Has_Element --
 910    -----------------
 911
 912    function Has_Element (Position : Cursor) return Boolean is
 913    begin
 914       return Position /= No_Element;
 915    end Has_Element;
 916
 917    -------------
 918    -- Include --
 919    -------------
 920
 921    procedure Include (Container : in out Set; New_Item  : Element_Type) is
 922       Position : Cursor;
 923       Inserted : Boolean;
 924
 925       X : Element_Access;
 926
 927    begin
 928       Insert (Container, New_Item, Position, Inserted);
 929
 930       if not Inserted then
 931          if Container.Tree.Lock > 0 then
 932             raise Program_Error with
 933               "attempt to tamper with cursors (set is locked)";
 934          end if;
 935
 936          X := Position.Node.Element;
 937          Position.Node.Element := new Element_Type'(New_Item);
 938          Free_Element (X);
 939       end if;
 940    end Include;
 941
 942    ------------
 943    -- Insert --
 944    ------------
 945
 946    procedure Insert
 947      (Container : in out Set;
 948       New_Item  : Element_Type;
 949       Position  : out Cursor;
 950       Inserted  : out Boolean)
 951    is
 952    begin
 953       Insert_Sans_Hint
 954         (Container.Tree,
 955          New_Item,
 956          Position.Node,
 957          Inserted);
 958
 959       Position.Container := Container'Unrestricted_Access;
 960    end Insert;
 961
 962    procedure Insert (Container : in out Set; New_Item  : Element_Type) is
 963       Position : Cursor;
 964       pragma Unreferenced (Position);
 965
 966       Inserted : Boolean;
 967
 968    begin
 969       Insert (Container, New_Item, Position, Inserted);
 970
 971       if not Inserted then
 972          raise Constraint_Error with
 973            "attempt to insert element already in set";
 974       end if;
 975    end Insert;
 976
 977    ----------------------
 978    -- Insert_Sans_Hint --
 979    ----------------------
 980
 981    procedure Insert_Sans_Hint
 982      (Tree     : in out Tree_Type;
 983       New_Item : Element_Type;
 984       Node     : out Node_Access;
 985       Inserted : out Boolean)
 986    is
 987       function New_Node return Node_Access;
 988       pragma Inline (New_Node);
 989
 990       procedure Insert_Post is
 991         new Element_Keys.Generic_Insert_Post (New_Node);
 992
 993       procedure Conditional_Insert_Sans_Hint is
 994         new Element_Keys.Generic_Conditional_Insert (Insert_Post);
 995
 996       --------------
 997       -- New_Node --
 998       --------------
 999
1000       function New_Node return Node_Access is
1001          Element : Element_Access := new Element_Type'(New_Item);
1002
1003       begin
1004          return new Node_Type'(Parent  => null,
1005                                Left    => null,
1006                                Right   => null,
1007                                Color   => Red_Black_Trees.Red,
1008                                Element => Element);
1009       exception
1010          when others =>
1011             Free_Element (Element);
1012             raise;
1013       end New_Node;
1014
1015    --  Start of processing for Insert_Sans_Hint
1016
1017    begin
1018       Conditional_Insert_Sans_Hint
1019         (Tree,
1020          New_Item,
1021          Node,
1022          Inserted);
1023    end Insert_Sans_Hint;
1024
1025    ----------------------
1026    -- Insert_With_Hint --
1027    ----------------------
1028
1029    procedure Insert_With_Hint
1030      (Dst_Tree : in out Tree_Type;
1031       Dst_Hint : Node_Access;
1032       Src_Node : Node_Access;
1033       Dst_Node : out Node_Access)
1034    is
1035       Success : Boolean;
1036       pragma Unreferenced (Success);
1037
1038       function New_Node return Node_Access;
1039
1040       procedure Insert_Post is
1041         new Element_Keys.Generic_Insert_Post (New_Node);
1042
1043       procedure Insert_Sans_Hint is
1044         new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1045
1046       procedure Insert_With_Hint is
1047          new Element_Keys.Generic_Conditional_Insert_With_Hint
1048             (Insert_Post,
1049              Insert_Sans_Hint);
1050
1051       --------------
1052       -- New_Node --
1053       --------------
1054
1055       function New_Node return Node_Access is
1056          Element : Element_Access :=
1057                      new Element_Type'(Src_Node.Element.all);
1058          Node    : Node_Access;
1059
1060       begin
1061          begin
1062             Node := new Node_Type;
1063          exception
1064             when others =>
1065                Free_Element (Element);
1066                raise;
1067          end;
1068
1069          Node.Element := Element;
1070          return Node;
1071       end New_Node;
1072
1073    --  Start of processing for Insert_With_Hint
1074
1075    begin
1076       Insert_With_Hint
1077         (Dst_Tree,
1078          Dst_Hint,
1079          Src_Node.Element.all,
1080          Dst_Node,
1081          Success);
1082    end Insert_With_Hint;
1083
1084    ------------------
1085    -- Intersection --
1086    ------------------
1087
1088    procedure Intersection (Target : in out Set; Source : Set) is
1089    begin
1090       Set_Ops.Intersection (Target.Tree, Source.Tree);
1091    end Intersection;
1092
1093    function Intersection (Left, Right : Set) return Set is
1094       Tree : constant Tree_Type :=
1095                Set_Ops.Intersection (Left.Tree, Right.Tree);
1096    begin
1097       return Set'(Controlled with Tree);
1098    end Intersection;
1099
1100    --------------
1101    -- Is_Empty --
1102    --------------
1103
1104    function Is_Empty (Container : Set) return Boolean is
1105    begin
1106       return Container.Tree.Length = 0;
1107    end Is_Empty;
1108
1109    -----------------------------
1110    -- Is_Greater_Element_Node --
1111    -----------------------------
1112
1113    function Is_Greater_Element_Node
1114      (Left  : Element_Type;
1115       Right : Node_Access) return Boolean is
1116    begin
1117       --  e > node same as node < e
1118
1119       return Right.Element.all < Left;
1120    end Is_Greater_Element_Node;
1121
1122    --------------------------
1123    -- Is_Less_Element_Node --
1124    --------------------------
1125
1126    function Is_Less_Element_Node
1127      (Left  : Element_Type;
1128       Right : Node_Access) return Boolean is
1129    begin
1130       return Left < Right.Element.all;
1131    end Is_Less_Element_Node;
1132
1133    -----------------------
1134    -- Is_Less_Node_Node --
1135    -----------------------
1136
1137    function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1138    begin
1139       return L.Element.all < R.Element.all;
1140    end Is_Less_Node_Node;
1141
1142    ---------------
1143    -- Is_Subset --
1144    ---------------
1145
1146    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1147    begin
1148       return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1149    end Is_Subset;
1150
1151    -------------
1152    -- Iterate --
1153    -------------
1154
1155    procedure Iterate
1156      (Container : Set;
1157       Process   : not null access procedure (Position : Cursor))
1158    is
1159       procedure Process_Node (Node : Node_Access);
1160       pragma Inline (Process_Node);
1161
1162       procedure Local_Iterate is
1163         new Tree_Operations.Generic_Iteration (Process_Node);
1164
1165       ------------------
1166       -- Process_Node --
1167       ------------------
1168
1169       procedure Process_Node (Node : Node_Access) is
1170       begin
1171          Process (Cursor'(Container'Unrestricted_Access, Node));
1172       end Process_Node;
1173
1174       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1175       B : Natural renames T.Busy;
1176
1177    --  Start of processing for Iterate
1178
1179    begin
1180       B := B + 1;
1181
1182       begin
1183          Local_Iterate (T);
1184       exception
1185          when others =>
1186             B := B - 1;
1187             raise;
1188       end;
1189
1190       B := B - 1;
1191    end Iterate;
1192
1193    ----------
1194    -- Last --
1195    ----------
1196
1197    function Last (Container : Set) return Cursor is
1198    begin
1199       if Container.Tree.Last = null then
1200          return No_Element;
1201       end if;
1202
1203       return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
1204    end Last;
1205
1206    ------------------
1207    -- Last_Element --
1208    ------------------
1209
1210    function Last_Element (Container : Set) return Element_Type is
1211    begin
1212       if Container.Tree.Last = null then
1213          raise Constraint_Error with "set is empty";
1214       end if;
1215
1216       return Container.Tree.Last.Element.all;
1217    end Last_Element;
1218
1219    ----------
1220    -- Left --
1221    ----------
1222
1223    function Left (Node : Node_Access) return Node_Access is
1224    begin
1225       return Node.Left;
1226    end Left;
1227
1228    ------------
1229    -- Length --
1230    ------------
1231
1232    function Length (Container : Set) return Count_Type is
1233    begin
1234       return Container.Tree.Length;
1235    end Length;
1236
1237    ----------
1238    -- Move --
1239    ----------
1240
1241    procedure Move is
1242       new Tree_Operations.Generic_Move (Clear);
1243
1244    procedure Move (Target : in out Set; Source : in out Set) is
1245    begin
1246       Move (Target => Target.Tree, Source => Source.Tree);
1247    end Move;
1248
1249    ----------
1250    -- Next --
1251    ----------
1252
1253    procedure Next (Position : in out Cursor) is
1254    begin
1255       Position := Next (Position);
1256    end Next;
1257
1258    function Next (Position : Cursor) return Cursor is
1259    begin
1260       if Position = No_Element then
1261          return No_Element;
1262       end if;
1263
1264       if Position.Node.Element = null then
1265          raise Program_Error with "Position cursor is bad";
1266       end if;
1267
1268       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1269                      "bad cursor in Next");
1270
1271       declare
1272          Node : constant Node_Access :=
1273                   Tree_Operations.Next (Position.Node);
1274
1275       begin
1276          if Node = null then
1277             return No_Element;
1278          end if;
1279
1280          return Cursor'(Position.Container, Node);
1281       end;
1282    end Next;
1283
1284    -------------
1285    -- Overlap --
1286    -------------
1287
1288    function Overlap (Left, Right : Set) return Boolean is
1289    begin
1290       return Set_Ops.Overlap (Left.Tree, Right.Tree);
1291    end Overlap;
1292
1293    ------------
1294    -- Parent --
1295    ------------
1296
1297    function Parent (Node : Node_Access) return Node_Access is
1298    begin
1299       return Node.Parent;
1300    end Parent;
1301
1302    --------------
1303    -- Previous --
1304    --------------
1305
1306    procedure Previous (Position : in out Cursor) is
1307    begin
1308       Position := Previous (Position);
1309    end Previous;
1310
1311    function Previous (Position : Cursor) return Cursor is
1312    begin
1313       if Position = No_Element then
1314          return No_Element;
1315       end if;
1316
1317       if Position.Node.Element = null then
1318          raise Program_Error with "Position cursor is bad";
1319       end if;
1320
1321       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1322                      "bad cursor in Previous");
1323
1324       declare
1325          Node : constant Node_Access :=
1326                   Tree_Operations.Previous (Position.Node);
1327
1328       begin
1329          if Node = null then
1330             return No_Element;
1331          end if;
1332
1333          return Cursor'(Position.Container, Node);
1334       end;
1335    end Previous;
1336
1337    -------------------
1338    -- Query_Element --
1339    -------------------
1340
1341    procedure Query_Element
1342      (Position  : Cursor;
1343       Process   : not null access procedure (Element : Element_Type))
1344    is
1345    begin
1346       if Position.Node = null then
1347          raise Constraint_Error with "Position cursor equals No_Element";
1348       end if;
1349
1350       if Position.Node.Element = null then
1351          raise Program_Error with "Position cursor is bad";
1352       end if;
1353
1354       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1355                      "bad cursor in Query_Element");
1356
1357       declare
1358          T : Tree_Type renames Position.Container.Tree;
1359
1360          B : Natural renames T.Busy;
1361          L : Natural renames T.Lock;
1362
1363       begin
1364          B := B + 1;
1365          L := L + 1;
1366
1367          begin
1368             Process (Position.Node.Element.all);
1369          exception
1370             when others =>
1371                L := L - 1;
1372                B := B - 1;
1373                raise;
1374          end;
1375
1376          L := L - 1;
1377          B := B - 1;
1378       end;
1379    end Query_Element;
1380
1381    ----------
1382    -- Read --
1383    ----------
1384
1385    procedure Read
1386      (Stream    : not null access Root_Stream_Type'Class;
1387       Container : out Set)
1388    is
1389       function Read_Node
1390         (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1391       pragma Inline (Read_Node);
1392
1393       procedure Read is
1394          new Tree_Operations.Generic_Read (Clear, Read_Node);
1395
1396       ---------------
1397       -- Read_Node --
1398       ---------------
1399
1400       function Read_Node
1401         (Stream : not null access Root_Stream_Type'Class) return Node_Access
1402       is
1403          Node : Node_Access := new Node_Type;
1404
1405       begin
1406          Node.Element := new Element_Type'(Element_Type'Input (Stream));
1407          return Node;
1408
1409       exception
1410          when others =>
1411             Free (Node);  --  Note that Free deallocates elem too
1412             raise;
1413       end Read_Node;
1414
1415    --  Start of processing for Read
1416
1417    begin
1418       Read (Stream, Container.Tree);
1419    end Read;
1420
1421    procedure Read
1422      (Stream : not null access Root_Stream_Type'Class;
1423       Item   : out Cursor)
1424    is
1425    begin
1426       raise Program_Error with "attempt to stream set cursor";
1427    end Read;
1428
1429    -------------
1430    -- Replace --
1431    -------------
1432
1433    procedure Replace (Container : in out Set; New_Item : Element_Type) is
1434       Node : constant Node_Access :=
1435                Element_Keys.Find (Container.Tree, New_Item);
1436
1437       X : Element_Access;
1438       pragma Warnings (Off, X);
1439
1440    begin
1441       if Node = null then
1442          raise Constraint_Error with "attempt to replace element not in set";
1443       end if;
1444
1445       if Container.Tree.Lock > 0 then
1446          raise Program_Error with
1447            "attempt to tamper with cursors (set is locked)";
1448       end if;
1449
1450       X := Node.Element;
1451       Node.Element := new Element_Type'(New_Item);
1452       Free_Element (X);
1453    end Replace;
1454
1455    ---------------------
1456    -- Replace_Element --
1457    ---------------------
1458
1459    procedure Replace_Element
1460      (Tree : in out Tree_Type;
1461       Node : Node_Access;
1462       Item : Element_Type)
1463    is
1464       pragma Assert (Node /= null);
1465       pragma Assert (Node.Element /= null);
1466
1467       function New_Node return Node_Access;
1468       pragma Inline (New_Node);
1469
1470       procedure Local_Insert_Post is
1471          new Element_Keys.Generic_Insert_Post (New_Node);
1472
1473       procedure Local_Insert_Sans_Hint is
1474          new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
1475
1476       procedure Local_Insert_With_Hint is
1477          new Element_Keys.Generic_Conditional_Insert_With_Hint
1478         (Local_Insert_Post,
1479          Local_Insert_Sans_Hint);
1480
1481       --------------
1482       -- New_Node --
1483       --------------
1484
1485       function New_Node return Node_Access is
1486       begin
1487          Node.Element := new Element_Type'(Item);  -- OK if fails
1488          Node.Color := Red;
1489          Node.Parent := null;
1490          Node.Right := null;
1491          Node.Left := null;
1492
1493          return Node;
1494       end New_Node;
1495
1496       Hint     : Node_Access;
1497       Result   : Node_Access;
1498       Inserted : Boolean;
1499
1500       X : Element_Access := Node.Element;
1501
1502       --  Start of processing for Insert
1503
1504    begin
1505       if Item < Node.Element.all
1506         or else Node.Element.all < Item
1507       then
1508          null;
1509
1510       else
1511          if Tree.Lock > 0 then
1512             raise Program_Error with
1513               "attempt to tamper with cursors (set is locked)";
1514          end if;
1515
1516          Node.Element := new Element_Type'(Item);
1517          Free_Element (X);
1518
1519          return;
1520       end if;
1521
1522       Hint := Element_Keys.Ceiling (Tree, Item);
1523
1524       if Hint = null then
1525          null;
1526
1527       elsif Item < Hint.Element.all then
1528          if Hint = Node then
1529             if Tree.Lock > 0 then
1530                raise Program_Error with
1531                  "attempt to tamper with cursors (set is locked)";
1532             end if;
1533
1534             Node.Element := new Element_Type'(Item);
1535             Free_Element (X);
1536
1537             return;
1538          end if;
1539
1540       else
1541          pragma Assert (not (Hint.Element.all < Item));
1542          raise Program_Error with "attempt to replace existing element";
1543       end if;
1544
1545       Tree_Operations.Delete_Node_Sans_Free (Tree, Node);  -- Checks busy-bit
1546
1547       Local_Insert_With_Hint
1548         (Tree     => Tree,
1549          Position => Hint,
1550          Key      => Item,
1551          Node     => Result,
1552          Inserted => Inserted);
1553
1554       pragma Assert (Inserted);
1555       pragma Assert (Result = Node);
1556
1557       Free_Element (X);
1558    end Replace_Element;
1559
1560    procedure Replace_Element
1561     (Container : in out Set;
1562      Position  : Cursor;
1563      New_Item  : Element_Type)
1564    is
1565    begin
1566       if Position.Node = null then
1567          raise Constraint_Error with "Position cursor equals No_Element";
1568       end if;
1569
1570       if Position.Node.Element = null then
1571          raise Program_Error with "Position cursor is bad";
1572       end if;
1573
1574       if Position.Container /= Container'Unrestricted_Access then
1575          raise Program_Error with "Position cursor designates wrong set";
1576       end if;
1577
1578       pragma Assert (Vet (Container.Tree, Position.Node),
1579                      "bad cursor in Replace_Element");
1580
1581       Replace_Element (Container.Tree, Position.Node, New_Item);
1582    end Replace_Element;
1583
1584    ---------------------
1585    -- Reverse_Iterate --
1586    ---------------------
1587
1588    procedure Reverse_Iterate
1589      (Container : Set;
1590       Process   : not null access procedure (Position : Cursor))
1591    is
1592       procedure Process_Node (Node : Node_Access);
1593       pragma Inline (Process_Node);
1594
1595       procedure Local_Reverse_Iterate is
1596          new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1597
1598       ------------------
1599       -- Process_Node --
1600       ------------------
1601
1602       procedure Process_Node (Node : Node_Access) is
1603       begin
1604          Process (Cursor'(Container'Unrestricted_Access, Node));
1605       end Process_Node;
1606
1607       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1608       B : Natural renames T.Busy;
1609
1610    --  Start of processing for Reverse_Iterate
1611
1612    begin
1613       B := B + 1;
1614
1615       begin
1616          Local_Reverse_Iterate (T);
1617       exception
1618          when others =>
1619             B := B - 1;
1620             raise;
1621       end;
1622
1623       B := B - 1;
1624    end Reverse_Iterate;
1625
1626    -----------
1627    -- Right --
1628    -----------
1629
1630    function Right (Node : Node_Access) return Node_Access is
1631    begin
1632       return Node.Right;
1633    end Right;
1634
1635    ---------------
1636    -- Set_Color --
1637    ---------------
1638
1639    procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1640    begin
1641       Node.Color := Color;
1642    end Set_Color;
1643
1644    --------------
1645    -- Set_Left --
1646    --------------
1647
1648    procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1649    begin
1650       Node.Left := Left;
1651    end Set_Left;
1652
1653    ----------------
1654    -- Set_Parent --
1655    ----------------
1656
1657    procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1658    begin
1659       Node.Parent := Parent;
1660    end Set_Parent;
1661
1662    ---------------
1663    -- Set_Right --
1664    ---------------
1665
1666    procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1667    begin
1668       Node.Right := Right;
1669    end Set_Right;
1670
1671    --------------------------
1672    -- Symmetric_Difference --
1673    --------------------------
1674
1675    procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1676    begin
1677       Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1678    end Symmetric_Difference;
1679
1680    function Symmetric_Difference (Left, Right : Set) return Set is
1681       Tree : constant Tree_Type :=
1682                Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1683    begin
1684       return Set'(Controlled with Tree);
1685    end Symmetric_Difference;
1686
1687    ------------
1688    -- To_Set --
1689    ------------
1690
1691    function To_Set (New_Item : Element_Type) return Set is
1692       Tree : Tree_Type;
1693
1694       Node     : Node_Access;
1695       Inserted : Boolean;
1696       pragma Unreferenced (Node, Inserted);
1697
1698    begin
1699       Insert_Sans_Hint (Tree, New_Item, Node, Inserted);
1700       return Set'(Controlled with Tree);
1701    end To_Set;
1702
1703    -----------
1704    -- Union --
1705    -----------
1706
1707    procedure Union (Target : in out Set; Source : Set) is
1708    begin
1709       Set_Ops.Union (Target.Tree, Source.Tree);
1710    end Union;
1711
1712    function Union (Left, Right : Set) return Set is
1713       Tree : constant Tree_Type :=
1714                Set_Ops.Union (Left.Tree, Right.Tree);
1715    begin
1716       return Set'(Controlled with Tree);
1717    end Union;
1718
1719    -----------
1720    -- Write --
1721    -----------
1722
1723    procedure Write
1724      (Stream    : not null access Root_Stream_Type'Class;
1725       Container : Set)
1726    is
1727       procedure Write_Node
1728         (Stream : not null access Root_Stream_Type'Class;
1729          Node   : Node_Access);
1730       pragma Inline (Write_Node);
1731
1732       procedure Write is
1733          new Tree_Operations.Generic_Write (Write_Node);
1734
1735       ----------------
1736       -- Write_Node --
1737       ----------------
1738
1739       procedure Write_Node
1740         (Stream : not null access Root_Stream_Type'Class;
1741          Node   : Node_Access)
1742       is
1743       begin
1744          Element_Type'Output (Stream, Node.Element.all);
1745       end Write_Node;
1746
1747    --  Start of processing for Write
1748
1749    begin
1750       Write (Stream, Container.Tree);
1751    end Write;
1752
1753    procedure Write
1754      (Stream : not null access Root_Stream_Type'Class;
1755       Item   : Cursor)
1756    is
1757    begin
1758       raise Program_Error with "attempt to stream set cursor";
1759    end Write;
1760
1761 end Ada.Containers.Indefinite_Ordered_Sets;