gcc/ada/a-ciorse.adb

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