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