gcc/ada/a-coormu.adb

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