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-2005, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- This specification is derived from the Ada Reference Manual for use with --
  13 -- GNAT. The copyright notice above, and the license provisions that follow --
  14 -- apply solely to the  contents of the part following the private keyword. --
  15 --                                                                          --
  16 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  17 -- terms of the  GNU General Public License as published  by the Free Soft- --
  18 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  19 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  20 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  21 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  22 -- for  more details.  You should have  received  a copy of the GNU General --
  23 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  24 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  25 -- Boston, MA 02110-1301, USA.                                              --
  26 --                                                                          --
  27 -- As a special exception,  if other files  instantiate  generics from this --
  28 -- unit, or you link  this unit with other files  to produce an executable, --
  29 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  30 -- covered  by the  GNU  General  Public  License.  This exception does not --
  31 -- however invalidate  any other reasons why  the executable file  might be --
  32 -- covered by the  GNU Public License.                                      --
  33 --                                                                          --
  34 -- This unit was originally developed by Matthew J Heaney.                  --
  35 ------------------------------------------------------------------------------
  36
  37 with Ada.Containers.Red_Black_Trees.Generic_Operations;
  38 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
  39
  40 with Ada.Containers.Red_Black_Trees.Generic_Keys;
  41 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
  42
  43 with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
  44 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
  45
  46 with Ada.Unchecked_Deallocation;
  47
  48 package body Ada.Containers.Indefinite_Ordered_Sets is
  49
  50    -----------------------
  51    -- Local Subprograms --
  52    -----------------------
  53
  54    function Color (Node : Node_Access) return Color_Type;
  55    pragma Inline (Color);
  56
  57    function Copy_Node (Source : Node_Access) return Node_Access;
  58    pragma Inline (Copy_Node);
  59
  60    procedure Free (X : in out Node_Access);
  61
  62    procedure Insert_Sans_Hint
  63      (Tree     : in out Tree_Type;
  64       New_Item : Element_Type;
  65       Node     : out Node_Access;
  66       Inserted : out Boolean);
  67
  68    procedure Insert_With_Hint
  69      (Dst_Tree : in out Tree_Type;
  70       Dst_Hint : Node_Access;
  71       Src_Node : Node_Access;
  72       Dst_Node : out Node_Access);
  73
  74    function Is_Greater_Element_Node
  75      (Left  : Element_Type;
  76       Right : Node_Access) return Boolean;
  77    pragma Inline (Is_Greater_Element_Node);
  78
  79    function Is_Less_Element_Node
  80      (Left  : Element_Type;
  81       Right : Node_Access) return Boolean;
  82    pragma Inline (Is_Less_Element_Node);
  83
  84    function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
  85    pragma Inline (Is_Less_Node_Node);
  86
  87    function Left (Node : Node_Access) return Node_Access;
  88    pragma Inline (Left);
  89
  90    function Parent (Node : Node_Access) return Node_Access;
  91    pragma Inline (Parent);
  92
  93    procedure Replace_Element
  94      (Tree : in out Tree_Type;
  95       Node : Node_Access;
  96       Item : Element_Type);
  97
  98    function Right (Node : Node_Access) return Node_Access;
  99    pragma Inline (Right);
 100
 101    procedure Set_Color (Node : Node_Access; Color : Color_Type);
 102    pragma Inline (Set_Color);
 103
 104    procedure Set_Left (Node : Node_Access; Left : Node_Access);
 105    pragma Inline (Set_Left);
 106
 107    procedure Set_Parent (Node   : Node_Access; Parent : Node_Access);
 108    pragma Inline (Set_Parent);
 109
 110    procedure Set_Right (Node : Node_Access; Right : Node_Access);
 111    pragma Inline (Set_Right);
 112
 113    --------------------------
 114    -- Local Instantiations --
 115    --------------------------
 116
 117    procedure Free_Element is
 118      new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
 119
 120    package Tree_Operations is
 121      new Red_Black_Trees.Generic_Operations (Tree_Types);
 122
 123    procedure Delete_Tree is
 124      new Tree_Operations.Generic_Delete_Tree (Free);
 125
 126    function Copy_Tree is
 127      new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
 128
 129    use Tree_Operations;
 130
 131    package Element_Keys is
 132      new Red_Black_Trees.Generic_Keys
 133        (Tree_Operations     => Tree_Operations,
 134         Key_Type            => Element_Type,
 135         Is_Less_Key_Node    => Is_Less_Element_Node,
 136         Is_Greater_Key_Node => Is_Greater_Element_Node);
 137
 138    package Set_Ops is
 139       new Generic_Set_Operations
 140         (Tree_Operations  => Tree_Operations,
 141          Insert_With_Hint => Insert_With_Hint,
 142          Copy_Tree        => Copy_Tree,
 143          Delete_Tree      => Delete_Tree,
 144          Is_Less          => Is_Less_Node_Node,
 145          Free             => Free);
 146
 147    ---------
 148    -- "<" --
 149    ---------
 150
 151    function "<" (Left, Right : Cursor) return Boolean is
 152    begin
 153       if Left.Node = null then
 154          raise Constraint_Error with "Left cursor equals No_Element";
 155       end if;
 156
 157       if Right.Node = null then
 158          raise Constraint_Error with "Right cursor equals No_Element";
 159       end if;
 160
 161       if Left.Node.Element = null then
 162          raise Program_Error with "Left cursor is bad";
 163       end if;
 164
 165       if Right.Node.Element = null then
 166          raise Program_Error with "Right cursor is bad";
 167       end if;
 168
 169       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 170                      "bad Left cursor in ""<""");
 171
 172       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 173                      "bad Right cursor in ""<""");
 174
 175       return Left.Node.Element.all < Right.Node.Element.all;
 176    end "<";
 177
 178    function "<" (Left : Cursor; Right : Element_Type) return Boolean is
 179    begin
 180       if Left.Node = null then
 181          raise Constraint_Error with "Left cursor equals No_Element";
 182       end if;
 183
 184       if Left.Node.Element = null then
 185          raise Program_Error with "Left cursor is bad";
 186       end if;
 187
 188       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 189                      "bad Left cursor in ""<""");
 190
 191       return Left.Node.Element.all < Right;
 192    end "<";
 193
 194    function "<" (Left : Element_Type; Right : Cursor) return Boolean is
 195    begin
 196       if Right.Node = null then
 197          raise Constraint_Error with "Right cursor equals No_Element";
 198       end if;
 199
 200       if Right.Node.Element = null then
 201          raise Program_Error with "Right cursor is bad";
 202       end if;
 203
 204       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 205                      "bad Right cursor in ""<""");
 206
 207       return Left < Right.Node.Element.all;
 208    end "<";
 209
 210    ---------
 211    -- "=" --
 212    ---------
 213
 214    function "=" (Left, Right : Set) return Boolean is
 215
 216       function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
 217       pragma Inline (Is_Equal_Node_Node);
 218
 219       function Is_Equal is
 220         new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
 221
 222       ------------------------
 223       -- Is_Equal_Node_Node --
 224       ------------------------
 225
 226       function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
 227       begin
 228          return L.Element.all = R.Element.all;
 229       end Is_Equal_Node_Node;
 230
 231    --  Start of processing for "="
 232
 233    begin
 234       return Is_Equal (Left.Tree, Right.Tree);
 235    end "=";
 236
 237    ---------
 238    -- ">" --
 239    ---------
 240
 241    function ">" (Left, Right : Cursor) return Boolean is
 242    begin
 243       if Left.Node = null then
 244          raise Constraint_Error with "Left cursor equals No_Element";
 245       end if;
 246
 247       if Right.Node = null then
 248          raise Constraint_Error with "Right cursor equals No_Element";
 249       end if;
 250
 251       if Left.Node.Element = null then
 252          raise Program_Error with "Left cursor is bad";
 253       end if;
 254
 255       if Right.Node.Element = null then
 256          raise Program_Error with "Right cursor is bad";
 257       end if;
 258
 259       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 260                      "bad Left cursor in "">""");
 261
 262       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 263                      "bad Right cursor in "">""");
 264
 265       --  L > R same as R < L
 266
 267       return Right.Node.Element.all < Left.Node.Element.all;
 268    end ">";
 269
 270    function ">" (Left : Cursor; Right : Element_Type) return Boolean is
 271    begin
 272       if Left.Node = null then
 273          raise Constraint_Error with "Left cursor equals No_Element";
 274       end if;
 275
 276       if Left.Node.Element = null then
 277          raise Program_Error with "Left cursor is bad";
 278       end if;
 279
 280       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 281                      "bad Left cursor in "">""");
 282
 283       return Right < Left.Node.Element.all;
 284    end ">";
 285
 286    function ">" (Left : Element_Type; Right : Cursor) return Boolean is
 287    begin
 288       if Right.Node = null then
 289          raise Constraint_Error with "Right cursor equals No_Element";
 290       end if;
 291
 292       if Right.Node.Element = null then
 293          raise Program_Error with "Right cursor is bad";
 294       end if;
 295
 296       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 297                      "bad Right cursor in "">""");
 298
 299       return Right.Node.Element.all < Left;
 300    end ">";
 301
 302    ------------
 303    -- Adjust --
 304    ------------
 305
 306    procedure Adjust is
 307       new Tree_Operations.Generic_Adjust (Copy_Tree);
 308
 309    procedure Adjust (Container : in out Set) is
 310    begin
 311       Adjust (Container.Tree);
 312    end Adjust;
 313
 314    -------------
 315    -- Ceiling --
 316    -------------
 317
 318    function Ceiling (Container : Set; Item : Element_Type) return Cursor is
 319       Node : constant Node_Access :=
 320                Element_Keys.Ceiling (Container.Tree, Item);
 321
 322    begin
 323       if Node = null then
 324          return No_Element;
 325       end if;
 326
 327       return Cursor'(Container'Unrestricted_Access, Node);
 328    end Ceiling;
 329
 330    -----------
 331    -- Clear --
 332    -----------
 333
 334    procedure Clear is
 335       new Tree_Operations.Generic_Clear (Delete_Tree);
 336
 337    procedure Clear (Container : in out Set) is
 338    begin
 339       Clear (Container.Tree);
 340    end Clear;
 341
 342    -----------
 343    -- Color --
 344    -----------
 345
 346    function Color (Node : Node_Access) return Color_Type is
 347    begin
 348       return Node.Color;
 349    end Color;
 350
 351    --------------
 352    -- Contains --
 353    --------------
 354
 355    function Contains (Container : Set; Item : Element_Type) return Boolean is
 356    begin
 357       return Find (Container, Item) /= No_Element;
 358    end Contains;
 359
 360    ---------------
 361    -- Copy_Node --
 362    ---------------
 363
 364    function Copy_Node (Source : Node_Access) return Node_Access is
 365       Element : Element_Access := new Element_Type'(Source.Element.all);
 366
 367    begin
 368       return new Node_Type'(Parent  => null,
 369                             Left    => null,
 370                             Right   => null,
 371                             Color   => Source.Color,
 372                             Element => Element);
 373    exception
 374       when others =>
 375          Free_Element (Element);
 376          raise;
 377    end Copy_Node;
 378
 379    ------------
 380    -- Delete --
 381    ------------
 382
 383    procedure Delete (Container : in out Set; Position : in out Cursor) is
 384    begin
 385       if Position.Node = null then
 386          raise Constraint_Error with "Position cursor equals No_Element";
 387       end if;
 388
 389       if Position.Node.Element = null then
 390          raise Program_Error with "Position cursor is bad";
 391       end if;
 392
 393       if Position.Container /= Container'Unrestricted_Access then
 394          raise Program_Error with "Position cursor designates wrong set";
 395       end if;
 396
 397       pragma Assert (Vet (Container.Tree, Position.Node),
 398                      "bad cursor in Delete");
 399
 400       Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
 401       Free (Position.Node);
 402       Position.Container := null;
 403    end Delete;
 404
 405    procedure Delete (Container : in out Set; Item : Element_Type) is
 406       X : Node_Access :=
 407             Element_Keys.Find (Container.Tree, Item);
 408
 409    begin
 410       if X = null then
 411          raise Constraint_Error with "attempt to delete element not in set";
 412       end if;
 413
 414       Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 415       Free (X);
 416    end Delete;
 417
 418    ------------------
 419    -- Delete_First --
 420    ------------------
 421
 422    procedure Delete_First (Container : in out Set) is
 423       Tree : Tree_Type renames Container.Tree;
 424       X    : Node_Access := Tree.First;
 425
 426    begin
 427       if X /= null then
 428          Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 429          Free (X);
 430       end if;
 431    end Delete_First;
 432
 433    -----------------
 434    -- Delete_Last --
 435    -----------------
 436
 437    procedure Delete_Last (Container : in out Set) is
 438       Tree : Tree_Type renames Container.Tree;
 439       X    : Node_Access := Tree.Last;
 440
 441    begin
 442       if X /= null then
 443          Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 444          Free (X);
 445       end if;
 446    end Delete_Last;
 447
 448    ----------------
 449    -- Difference --
 450    ----------------
 451
 452    procedure Difference (Target : in out Set; Source : Set) is
 453    begin
 454       Set_Ops.Difference (Target.Tree, Source.Tree);
 455    end Difference;
 456
 457    function Difference (Left, Right : Set) return Set is
 458       Tree : constant Tree_Type :=
 459                Set_Ops.Difference (Left.Tree, Right.Tree);
 460    begin
 461       return Set'(Controlled with Tree);
 462    end Difference;
 463
 464    -------------
 465    -- Element --
 466    -------------
 467
 468    function Element (Position : Cursor) return Element_Type is
 469    begin
 470       if Position.Node = null then
 471          raise Constraint_Error with "Position cursor equals No_Element";
 472       end if;
 473
 474       if Position.Node.Element = null then
 475          raise Program_Error with "Position cursor is bad";
 476       end if;
 477
 478       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 479                      "bad cursor in Element");
 480
 481       return Position.Node.Element.all;
 482    end Element;
 483
 484    -------------------------
 485    -- Equivalent_Elements --
 486    -------------------------
 487
 488    function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
 489    begin
 490       if Left < Right
 491         or else Right < Left
 492       then
 493          return False;
 494       else
 495          return True;
 496       end if;
 497    end Equivalent_Elements;
 498
 499    ---------------------
 500    -- Equivalent_Sets --
 501    ---------------------
 502
 503    function Equivalent_Sets (Left, Right : Set) return Boolean is
 504
 505       function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
 506       pragma Inline (Is_Equivalent_Node_Node);
 507
 508       function Is_Equivalent is
 509          new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
 510
 511       -----------------------------
 512       -- Is_Equivalent_Node_Node --
 513       -----------------------------
 514
 515       function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
 516       begin
 517          if L.Element.all < R.Element.all then
 518             return False;
 519          elsif R.Element.all < L.Element.all then
 520             return False;
 521          else
 522             return True;
 523          end if;
 524       end Is_Equivalent_Node_Node;
 525
 526    --  Start of processing for Equivalent_Sets
 527
 528    begin
 529       return Is_Equivalent (Left.Tree, Right.Tree);
 530    end Equivalent_Sets;
 531
 532    -------------
 533    -- Exclude --
 534    -------------
 535
 536    procedure Exclude (Container : in out Set; Item : Element_Type) is
 537       X : Node_Access :=
 538             Element_Keys.Find (Container.Tree, Item);
 539
 540    begin
 541       if X /= null then
 542          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 543          Free (X);
 544       end if;
 545    end Exclude;
 546
 547    ----------
 548    -- Find --
 549    ----------
 550
 551    function Find (Container : Set; Item : Element_Type) return Cursor is
 552       Node : constant Node_Access :=
 553                Element_Keys.Find (Container.Tree, Item);
 554
 555    begin
 556       if Node = null then
 557          return No_Element;
 558       end if;
 559
 560       return Cursor'(Container'Unrestricted_Access, Node);
 561    end Find;
 562
 563    -----------
 564    -- First --
 565    -----------
 566
 567    function First (Container : Set) return Cursor is
 568    begin
 569       if Container.Tree.First = null then
 570          return No_Element;
 571       end if;
 572
 573       return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
 574    end First;
 575
 576    -------------------
 577    -- First_Element --
 578    -------------------
 579
 580    function First_Element (Container : Set) return Element_Type is
 581    begin
 582       if Container.Tree.First = null then
 583          raise Constraint_Error with "set is empty";
 584       end if;
 585
 586       return Container.Tree.First.Element.all;
 587    end First_Element;
 588
 589    -----------
 590    -- Floor --
 591    -----------
 592
 593    function Floor (Container : Set; Item : Element_Type) return Cursor is
 594       Node : constant Node_Access :=
 595                Element_Keys.Floor (Container.Tree, Item);
 596
 597    begin
 598       if Node = null then
 599          return No_Element;
 600       end if;
 601
 602       return Cursor'(Container'Unrestricted_Access, Node);
 603    end Floor;
 604
 605    ----------
 606    -- Free --
 607    ----------
 608
 609    procedure Free (X : in out Node_Access) is
 610       procedure Deallocate is
 611         new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 612
 613    begin
 614       if X = null then
 615          return;
 616       end if;
 617
 618       X.Parent := X;
 619       X.Left := X;
 620       X.Right := X;
 621
 622       begin
 623          Free_Element (X.Element);
 624       exception
 625          when others =>
 626             X.Element := null;
 627             Deallocate (X);
 628             raise;
 629       end;
 630
 631       Deallocate (X);
 632    end Free;
 633
 634    ------------------
 635    -- Generic_Keys --
 636    ------------------
 637
 638    package body Generic_Keys is
 639
 640       -----------------------
 641       -- Local Subprograms --
 642       -----------------------
 643
 644       function Is_Greater_Key_Node
 645         (Left  : Key_Type;
 646          Right : Node_Access) return Boolean;
 647       pragma Inline (Is_Greater_Key_Node);
 648
 649       function Is_Less_Key_Node
 650         (Left  : Key_Type;
 651          Right : Node_Access) return Boolean;
 652       pragma Inline (Is_Less_Key_Node);
 653
 654       --------------------------
 655       -- Local Instantiations --
 656       --------------------------
 657
 658       package Key_Keys is
 659         new Red_Black_Trees.Generic_Keys
 660           (Tree_Operations     => Tree_Operations,
 661            Key_Type            => Key_Type,
 662            Is_Less_Key_Node    => Is_Less_Key_Node,
 663            Is_Greater_Key_Node => Is_Greater_Key_Node);
 664
 665       -------------
 666       -- Ceiling --
 667       -------------
 668
 669       function Ceiling (Container : Set; Key : Key_Type) return Cursor is
 670          Node : constant Node_Access :=
 671                   Key_Keys.Ceiling (Container.Tree, Key);
 672
 673       begin
 674          if Node = null then
 675             return No_Element;
 676          end if;
 677
 678          return Cursor'(Container'Unrestricted_Access, Node);
 679       end Ceiling;
 680
 681       --------------
 682       -- Contains --
 683       --------------
 684
 685       function Contains (Container : Set; Key : Key_Type) return Boolean is
 686       begin
 687          return Find (Container, Key) /= No_Element;
 688       end Contains;
 689
 690       ------------
 691       -- Delete --
 692       ------------
 693
 694       procedure Delete (Container : in out Set; Key : Key_Type) is
 695          X : Node_Access := Key_Keys.Find (Container.Tree, Key);
 696
 697       begin
 698          if X = null then
 699             raise Constraint_Error with "attempt to delete key not in set";
 700          end if;
 701
 702          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 703          Free (X);
 704       end Delete;
 705
 706       -------------
 707       -- Element --
 708       -------------
 709
 710       function Element (Container : Set; Key : Key_Type) return Element_Type is
 711          Node : constant Node_Access :=
 712                   Key_Keys.Find (Container.Tree, Key);
 713
 714       begin
 715          if Node = null then
 716             raise Constraint_Error with "key not in set";
 717          end if;
 718
 719          return Node.Element.all;
 720       end Element;
 721
 722       ---------------------
 723       -- Equivalent_Keys --
 724       ---------------------
 725
 726       function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
 727       begin
 728          if Left < Right
 729            or else Right < Left
 730          then
 731             return False;
 732          else
 733             return True;
 734          end if;
 735       end Equivalent_Keys;
 736
 737       -------------
 738       -- Exclude --
 739       -------------
 740
 741       procedure Exclude (Container : in out Set; Key : Key_Type) is
 742          X : Node_Access := Key_Keys.Find (Container.Tree, Key);
 743
 744       begin
 745          if X /= null then
 746             Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 747             Free (X);
 748          end if;
 749       end Exclude;
 750
 751       ----------
 752       -- Find --
 753       ----------
 754
 755       function Find (Container : Set; Key : Key_Type) return Cursor is
 756          Node : constant Node_Access :=
 757                   Key_Keys.Find (Container.Tree, Key);
 758
 759       begin
 760          if Node = null then
 761             return No_Element;
 762          end if;
 763
 764          return Cursor'(Container'Unrestricted_Access, Node);
 765       end Find;
 766
 767       -----------
 768       -- Floor --
 769       -----------
 770
 771       function Floor (Container : Set; Key : Key_Type) return Cursor is
 772          Node : constant Node_Access :=
 773                   Key_Keys.Floor (Container.Tree, Key);
 774
 775       begin
 776          if Node = null then
 777             return No_Element;
 778          end if;
 779
 780          return Cursor'(Container'Unrestricted_Access, Node);
 781       end Floor;
 782
 783       -------------------------
 784       -- Is_Greater_Key_Node --
 785       -------------------------
 786
 787       function Is_Greater_Key_Node
 788         (Left  : Key_Type;
 789          Right : Node_Access) return Boolean is
 790       begin
 791          return Key (Right.Element.all) < Left;
 792       end Is_Greater_Key_Node;
 793
 794       ----------------------
 795       -- Is_Less_Key_Node --
 796       ----------------------
 797
 798       function Is_Less_Key_Node
 799         (Left  : Key_Type;
 800          Right : Node_Access) return Boolean is
 801       begin
 802          return Left < Key (Right.Element.all);
 803       end Is_Less_Key_Node;
 804
 805       ---------
 806       -- Key --
 807       ---------
 808
 809       function Key (Position : Cursor) return Key_Type is
 810       begin
 811          if Position.Node = null then
 812             raise Constraint_Error with
 813               "Position cursor equals No_Element";
 814          end if;
 815
 816          if Position.Node.Element = null then
 817             raise Program_Error with
 818               "Position cursor is bad";
 819          end if;
 820
 821          pragma Assert (Vet (Position.Container.Tree, Position.Node),
 822                         "bad cursor in Key");
 823
 824          return Key (Position.Node.Element.all);
 825       end Key;
 826
 827       -------------
 828       -- Replace --
 829       -------------
 830
 831       procedure Replace
 832         (Container : in out Set;
 833          Key       : Key_Type;
 834          New_Item  : Element_Type)
 835       is
 836          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 837
 838       begin
 839          if Node = null then
 840             raise Constraint_Error with
 841               "attempt to replace key not in set";
 842          end if;
 843
 844          Replace_Element (Container.Tree, Node, New_Item);
 845       end Replace;
 846
 847       -----------------------------------
 848       -- Update_Element_Preserving_Key --
 849       -----------------------------------
 850
 851       procedure Update_Element_Preserving_Key
 852         (Container : in out Set;
 853          Position  : Cursor;
 854          Process   : not null access
 855                         procedure (Element : in out Element_Type))
 856       is
 857          Tree : Tree_Type renames Container.Tree;
 858
 859       begin
 860          if Position.Node = null then
 861             raise Constraint_Error with "Position cursor equals No_Element";
 862          end if;
 863
 864          if Position.Node.Element = null then
 865             raise Program_Error with "Position cursor is bad";
 866          end if;
 867
 868          if Position.Container /= Container'Unrestricted_Access then
 869             raise Program_Error with "Position cursor designates wrong set";
 870          end if;
 871
 872          pragma Assert (Vet (Container.Tree, Position.Node),
 873                         "bad cursor in Update_Element_Preserving_Key");
 874
 875          declare
 876             E : Element_Type renames Position.Node.Element.all;
 877             K : constant Key_Type := Key (E);
 878
 879             B : Natural renames Tree.Busy;
 880             L : Natural renames Tree.Lock;
 881
 882          begin
 883             B := B + 1;
 884             L := L + 1;
 885
 886             begin
 887                Process (E);
 888             exception
 889                when others =>
 890                   L := L - 1;
 891                   B := B - 1;
 892                   raise;
 893             end;
 894
 895             L := L - 1;
 896             B := B - 1;
 897
 898             if Equivalent_Keys (K, Key (E)) then
 899                return;
 900             end if;
 901          end;
 902
 903          declare
 904             X : Node_Access := Position.Node;
 905          begin
 906             Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 907             Free (X);
 908          end;
 909
 910          raise Program_Error with "key was modified";
 911       end Update_Element_Preserving_Key;
 912
 913    end Generic_Keys;
 914
 915    -----------------
 916    -- Has_Element --
 917    -----------------
 918
 919    function Has_Element (Position : Cursor) return Boolean is
 920    begin
 921       return Position /= No_Element;
 922    end Has_Element;
 923
 924    -------------
 925    -- Include --
 926    -------------
 927
 928    procedure Include (Container : in out Set; New_Item  : Element_Type) is
 929       Position : Cursor;
 930       Inserted : Boolean;
 931
 932       X : Element_Access;
 933
 934    begin
 935       Insert (Container, New_Item, Position, Inserted);
 936
 937       if not Inserted then
 938          if Container.Tree.Lock > 0 then
 939             raise Program_Error with
 940               "attempt to tamper with cursors (set is locked)";
 941          end if;
 942
 943          X := Position.Node.Element;
 944          Position.Node.Element := new Element_Type'(New_Item);
 945          Free_Element (X);
 946       end if;
 947    end Include;
 948
 949    ------------
 950    -- Insert --
 951    ------------
 952
 953    procedure Insert
 954      (Container : in out Set;
 955       New_Item  : Element_Type;
 956       Position  : out Cursor;
 957       Inserted  : out Boolean)
 958    is
 959    begin
 960       Insert_Sans_Hint
 961         (Container.Tree,
 962          New_Item,
 963          Position.Node,
 964          Inserted);
 965
 966       Position.Container := Container'Unrestricted_Access;
 967    end Insert;
 968
 969    procedure Insert (Container : in out Set; New_Item  : Element_Type) is
 970       Position : Cursor;
 971       Inserted : Boolean;
 972    begin
 973       Insert (Container, New_Item, Position, Inserted);
 974
 975       if not Inserted then
 976          raise Constraint_Error with
 977            "attempt to insert element already in set";
 978       end if;
 979    end Insert;
 980
 981    ----------------------
 982    -- Insert_Sans_Hint --
 983    ----------------------
 984
 985    procedure Insert_Sans_Hint
 986      (Tree     : in out Tree_Type;
 987       New_Item : Element_Type;
 988       Node     : out Node_Access;
 989       Inserted : out Boolean)
 990    is
 991       function New_Node return Node_Access;
 992       pragma Inline (New_Node);
 993
 994       procedure Insert_Post is
 995         new Element_Keys.Generic_Insert_Post (New_Node);
 996
 997       procedure Conditional_Insert_Sans_Hint is
 998         new Element_Keys.Generic_Conditional_Insert (Insert_Post);
 999
1000       --------------
1001       -- New_Node --
1002       --------------
1003
1004       function New_Node return Node_Access is
1005          Element : Element_Access := new Element_Type'(New_Item);
1006
1007       begin
1008          return new Node_Type'(Parent  => null,
1009                                Left    => null,
1010                                Right   => null,
1011                                Color   => Red_Black_Trees.Red,
1012                                Element => Element);
1013       exception
1014          when others =>
1015             Free_Element (Element);
1016             raise;
1017       end New_Node;
1018
1019    --  Start of processing for Insert_Sans_Hint
1020
1021    begin
1022       Conditional_Insert_Sans_Hint
1023         (Tree,
1024          New_Item,
1025          Node,
1026          Inserted);
1027    end Insert_Sans_Hint;
1028
1029    ----------------------
1030    -- Insert_With_Hint --
1031    ----------------------
1032
1033    procedure Insert_With_Hint
1034      (Dst_Tree : in out Tree_Type;
1035       Dst_Hint : Node_Access;
1036       Src_Node : Node_Access;
1037       Dst_Node : out Node_Access)
1038    is
1039       Success  : Boolean;
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    : access Root_Stream_Type'Class;
1390       Container : out Set)
1391    is
1392       function Read_Node
1393         (Stream : 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 : 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 : 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
1442    begin
1443       if Node = null then
1444          raise Constraint_Error with "attempt to replace element not in set";
1445       end if;
1446
1447       if Container.Tree.Lock > 0 then
1448          raise Program_Error with
1449            "attempt to tamper with cursors (set is locked)";
1450       end if;
1451
1452       X := Node.Element;
1453       Node.Element := new Element_Type'(New_Item);
1454       Free_Element (X);
1455    end Replace;
1456
1457    ---------------------
1458    -- Replace_Element --
1459    ---------------------
1460
1461    procedure Replace_Element
1462      (Tree : in out Tree_Type;
1463       Node : Node_Access;
1464       Item : Element_Type)
1465    is
1466    begin
1467       if Item < Node.Element.all
1468         or else Node.Element.all < Item
1469       then
1470          null;
1471       else
1472          if Tree.Lock > 0 then
1473             raise Program_Error with
1474               "attempt to tamper with cursors (set is locked)";
1475          end if;
1476
1477          declare
1478             X : Element_Access := Node.Element;
1479          begin
1480             Node.Element := new Element_Type'(Item);
1481             Free_Element (X);
1482          end;
1483
1484          return;
1485       end if;
1486
1487       Tree_Operations.Delete_Node_Sans_Free (Tree, Node);  -- Checks busy-bit
1488
1489       Insert_New_Item : declare
1490          function New_Node return Node_Access;
1491          pragma Inline (New_Node);
1492
1493          procedure Insert_Post is
1494             new Element_Keys.Generic_Insert_Post (New_Node);
1495
1496          procedure Insert is
1497             new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1498
1499          --------------
1500          -- New_Node --
1501          --------------
1502
1503          function New_Node return Node_Access is
1504          begin
1505             Node.Element := new Element_Type'(Item);  -- OK if fails
1506             Node.Color := Red;
1507             Node.Parent := null;
1508             Node.Right := null;
1509             Node.Left := null;
1510
1511             return Node;
1512          end New_Node;
1513
1514          Result   : Node_Access;
1515          Inserted : Boolean;
1516
1517          X : Element_Access := Node.Element;
1518
1519       --  Start of processing for Insert_New_Item
1520
1521       begin
1522          Attempt_Insert : begin
1523             Insert
1524               (Tree    => Tree,
1525                Key     => Item,
1526                Node    => Result,
1527                Success => Inserted);  --  TODO: change name of formal param
1528          exception
1529             when others =>
1530                Inserted := False;
1531          end Attempt_Insert;
1532
1533          if Inserted then
1534             pragma Assert (Result = Node);
1535             Free_Element (X);  -- OK if fails
1536             return;
1537          end if;
1538       end Insert_New_Item;
1539
1540       Reinsert_Old_Element : declare
1541          function New_Node return Node_Access;
1542          pragma Inline (New_Node);
1543
1544          procedure Insert_Post is
1545             new Element_Keys.Generic_Insert_Post (New_Node);
1546
1547          procedure Insert is
1548             new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1549
1550          --------------
1551          -- New_Node --
1552          --------------
1553
1554          function New_Node return Node_Access is
1555          begin
1556             Node.Color := Red;
1557             Node.Parent := null;
1558             Node.Right := null;
1559             Node.Left := null;
1560
1561             return Node;
1562          end New_Node;
1563
1564          Result   : Node_Access;
1565          Inserted : Boolean;
1566
1567       --  Start of processing for Reinsert_Old_Element
1568
1569       begin
1570          Insert
1571            (Tree    => Tree,
1572             Key     => Node.Element.all,
1573             Node    => Result,
1574             Success => Inserted);  --  TODO: change name of formal param
1575       exception
1576          when others =>
1577             null;
1578       end Reinsert_Old_Element;
1579
1580       raise Program_Error with "attempt to replace existing element";
1581    end Replace_Element;
1582
1583    procedure Replace_Element
1584     (Container : in out Set;
1585      Position  : Cursor;
1586      New_Item  : Element_Type)
1587    is
1588    begin
1589       if Position.Node = null then
1590          raise Constraint_Error with "Position cursor equals No_Element";
1591       end if;
1592
1593       if Position.Node.Element = null then
1594          raise Program_Error with "Position cursor is bad";
1595       end if;
1596
1597       if Position.Container /= Container'Unrestricted_Access then
1598          raise Program_Error with "Position cursor designates wrong set";
1599       end if;
1600
1601       pragma Assert (Vet (Container.Tree, Position.Node),
1602                      "bad cursor in Replace_Element");
1603
1604       Replace_Element (Container.Tree, Position.Node, New_Item);
1605    end Replace_Element;
1606
1607    ---------------------
1608    -- Reverse_Iterate --
1609    ---------------------
1610
1611    procedure Reverse_Iterate
1612      (Container : Set;
1613       Process   : not null access procedure (Position : Cursor))
1614    is
1615       procedure Process_Node (Node : Node_Access);
1616       pragma Inline (Process_Node);
1617
1618       procedure Local_Reverse_Iterate is
1619          new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1620
1621       ------------------
1622       -- Process_Node --
1623       ------------------
1624
1625       procedure Process_Node (Node : Node_Access) is
1626       begin
1627          Process (Cursor'(Container'Unrestricted_Access, Node));
1628       end Process_Node;
1629
1630       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1631       B : Natural renames T.Busy;
1632
1633    --  Start of processing for Reverse_Iterate
1634
1635    begin
1636       B := B + 1;
1637
1638       begin
1639          Local_Reverse_Iterate (T);
1640       exception
1641          when others =>
1642             B := B - 1;
1643             raise;
1644       end;
1645
1646       B := B - 1;
1647    end Reverse_Iterate;
1648
1649    -----------
1650    -- Right --
1651    -----------
1652
1653    function Right (Node : Node_Access) return Node_Access is
1654    begin
1655       return Node.Right;
1656    end Right;
1657
1658    ---------------
1659    -- Set_Color --
1660    ---------------
1661
1662    procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1663    begin
1664       Node.Color := Color;
1665    end Set_Color;
1666
1667    --------------
1668    -- Set_Left --
1669    --------------
1670
1671    procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1672    begin
1673       Node.Left := Left;
1674    end Set_Left;
1675
1676    ----------------
1677    -- Set_Parent --
1678    ----------------
1679
1680    procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1681    begin
1682       Node.Parent := Parent;
1683    end Set_Parent;
1684
1685    ---------------
1686    -- Set_Right --
1687    ---------------
1688
1689    procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1690    begin
1691       Node.Right := Right;
1692    end Set_Right;
1693
1694    --------------------------
1695    -- Symmetric_Difference --
1696    --------------------------
1697
1698    procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1699    begin
1700       Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1701    end Symmetric_Difference;
1702
1703    function Symmetric_Difference (Left, Right : Set) return Set is
1704       Tree : constant Tree_Type :=
1705                Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1706    begin
1707       return Set'(Controlled with Tree);
1708    end Symmetric_Difference;
1709
1710    ------------
1711    -- To_Set --
1712    ------------
1713
1714    function To_Set (New_Item : Element_Type) return Set is
1715       Tree     : Tree_Type;
1716       Node     : Node_Access;
1717       Inserted : Boolean;
1718
1719    begin
1720       Insert_Sans_Hint (Tree, New_Item, Node, Inserted);
1721       return Set'(Controlled with Tree);
1722    end To_Set;
1723
1724    -----------
1725    -- Union --
1726    -----------
1727
1728    procedure Union (Target : in out Set; Source : Set) is
1729    begin
1730       Set_Ops.Union (Target.Tree, Source.Tree);
1731    end Union;
1732
1733    function Union (Left, Right : Set) return Set is
1734       Tree : constant Tree_Type :=
1735                Set_Ops.Union (Left.Tree, Right.Tree);
1736    begin
1737       return Set'(Controlled with Tree);
1738    end Union;
1739
1740    -----------
1741    -- Write --
1742    -----------
1743
1744    procedure Write
1745      (Stream    : access Root_Stream_Type'Class;
1746       Container : Set)
1747    is
1748       procedure Write_Node
1749         (Stream : access Root_Stream_Type'Class;
1750          Node   : Node_Access);
1751       pragma Inline (Write_Node);
1752
1753       procedure Write is
1754          new Tree_Operations.Generic_Write (Write_Node);
1755
1756       ----------------
1757       -- Write_Node --
1758       ----------------
1759
1760       procedure Write_Node
1761         (Stream : access Root_Stream_Type'Class;
1762          Node   : Node_Access)
1763       is
1764       begin
1765          Element_Type'Output (Stream, Node.Element.all);
1766       end Write_Node;
1767
1768    --  Start of processing for Write
1769
1770    begin
1771       Write (Stream, Container.Tree);
1772    end Write;
1773
1774    procedure Write
1775      (Stream : access Root_Stream_Type'Class;
1776       Item   : Cursor)
1777    is
1778    begin
1779       raise Program_Error with "attempt to stream set cursor";
1780    end Write;
1781
1782 end Ada.Containers.Indefinite_Ordered_Sets;