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 -- 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    begin
 987       Insert (Container, New_Item, Position);
 988    end Insert;
 989
 990    procedure Insert
 991      (Container : in out Set;
 992       New_Item  : Element_Type;
 993       Position  : out Cursor)
 994    is
 995    begin
 996       Insert_Sans_Hint (Container.Tree, New_Item, Position.Node);
 997       Position.Container := Container'Unrestricted_Access;
 998    end Insert;
 999
1000    ----------------------
1001    -- Insert_Sans_Hint --
1002    ----------------------
1003
1004    procedure Insert_Sans_Hint
1005      (Tree     : in out Tree_Type;
1006       New_Item : Element_Type;
1007       Node     : out Node_Access)
1008    is
1009       function New_Node return Node_Access;
1010       pragma Inline (New_Node);
1011
1012       procedure Insert_Post is
1013         new Element_Keys.Generic_Insert_Post (New_Node);
1014
1015       procedure Unconditional_Insert is
1016         new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1017
1018       --------------
1019       -- New_Node --
1020       --------------
1021
1022       function New_Node return Node_Access is
1023          Node : constant Node_Access :=
1024                   new Node_Type'(Parent  => null,
1025                                  Left    => null,
1026                                  Right   => null,
1027                                  Color   => Red_Black_Trees.Red,
1028                                  Element => New_Item);
1029       begin
1030          return Node;
1031       end New_Node;
1032
1033    --  Start of processing for Insert_Sans_Hint
1034
1035    begin
1036       Unconditional_Insert (Tree, New_Item, Node);
1037    end Insert_Sans_Hint;
1038
1039    ----------------------
1040    -- Insert_With_Hint --
1041    ----------------------
1042
1043    procedure Insert_With_Hint
1044      (Dst_Tree : in out Tree_Type;
1045       Dst_Hint : Node_Access;
1046       Src_Node : Node_Access;
1047       Dst_Node : out Node_Access)
1048    is
1049       function New_Node return Node_Access;
1050       pragma Inline (New_Node);
1051
1052       procedure Insert_Post is
1053         new Element_Keys.Generic_Insert_Post (New_Node);
1054
1055       procedure Insert_Sans_Hint is
1056         new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1057
1058       procedure Local_Insert_With_Hint is
1059         new Element_Keys.Generic_Unconditional_Insert_With_Hint
1060           (Insert_Post,
1061            Insert_Sans_Hint);
1062
1063       --------------
1064       -- New_Node --
1065       --------------
1066
1067       function New_Node return Node_Access is
1068          Node : constant Node_Access :=
1069                   new Node_Type'(Parent  => null,
1070                                  Left    => null,
1071                                  Right   => null,
1072                                  Color   => Red,
1073                                  Element => Src_Node.Element);
1074       begin
1075          return Node;
1076       end New_Node;
1077
1078    --  Start of processing for Insert_With_Hint
1079
1080    begin
1081       Local_Insert_With_Hint
1082         (Dst_Tree,
1083          Dst_Hint,
1084          Src_Node.Element,
1085          Dst_Node);
1086    end Insert_With_Hint;
1087
1088    ------------------
1089    -- Intersection --
1090    ------------------
1091
1092    procedure Intersection (Target : in out Set; Source : Set) is
1093    begin
1094       Set_Ops.Intersection (Target.Tree, Source.Tree);
1095    end Intersection;
1096
1097    function Intersection (Left, Right : Set) return Set is
1098       Tree : constant Tree_Type :=
1099                Set_Ops.Intersection (Left.Tree, Right.Tree);
1100    begin
1101       return Set'(Controlled with Tree);
1102    end Intersection;
1103
1104    --------------
1105    -- Is_Empty --
1106    --------------
1107
1108    function Is_Empty (Container : Set) return Boolean is
1109    begin
1110       return Container.Tree.Length = 0;
1111    end Is_Empty;
1112
1113    ------------------------
1114    -- Is_Equal_Node_Node --
1115    ------------------------
1116
1117    function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1118    begin
1119       return L.Element = R.Element;
1120    end Is_Equal_Node_Node;
1121
1122    -----------------------------
1123    -- Is_Greater_Element_Node --
1124    -----------------------------
1125
1126    function Is_Greater_Element_Node
1127      (Left  : Element_Type;
1128       Right : Node_Access) return Boolean
1129    is
1130    begin
1131       --  e > node same as node < e
1132
1133       return Right.Element < Left;
1134    end Is_Greater_Element_Node;
1135
1136    --------------------------
1137    -- Is_Less_Element_Node --
1138    --------------------------
1139
1140    function Is_Less_Element_Node
1141      (Left  : Element_Type;
1142       Right : Node_Access) return Boolean
1143    is
1144    begin
1145       return Left < Right.Element;
1146    end Is_Less_Element_Node;
1147
1148    -----------------------
1149    -- Is_Less_Node_Node --
1150    -----------------------
1151
1152    function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1153    begin
1154       return L.Element < R.Element;
1155    end Is_Less_Node_Node;
1156
1157    ---------------
1158    -- Is_Subset --
1159    ---------------
1160
1161    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1162    begin
1163       return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1164    end Is_Subset;
1165
1166    -------------
1167    -- Iterate --
1168    -------------
1169
1170    procedure Iterate
1171      (Container : Set;
1172       Process   : not null access procedure (Position : Cursor))
1173    is
1174       procedure Process_Node (Node : Node_Access);
1175       pragma Inline (Process_Node);
1176
1177       procedure Local_Iterate is
1178         new Tree_Operations.Generic_Iteration (Process_Node);
1179
1180       ------------------
1181       -- Process_Node --
1182       ------------------
1183
1184       procedure Process_Node (Node : Node_Access) is
1185       begin
1186          Process (Cursor'(Container'Unrestricted_Access, Node));
1187       end Process_Node;
1188
1189       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1190       B : Natural renames T.Busy;
1191
1192    --  Start of processing for Iterate
1193
1194    begin
1195       B := B + 1;
1196
1197       begin
1198          Local_Iterate (T);
1199       exception
1200          when others =>
1201             B := B - 1;
1202             raise;
1203       end;
1204
1205       B := B - 1;
1206    end Iterate;
1207
1208    procedure Iterate
1209      (Container : Set;
1210       Item      : Element_Type;
1211       Process   : not null access procedure (Position : Cursor))
1212    is
1213       procedure Process_Node (Node : Node_Access);
1214       pragma Inline (Process_Node);
1215
1216       procedure Local_Iterate is
1217         new Element_Keys.Generic_Iteration (Process_Node);
1218
1219       ------------------
1220       -- Process_Node --
1221       ------------------
1222
1223       procedure Process_Node (Node : Node_Access) is
1224       begin
1225          Process (Cursor'(Container'Unrestricted_Access, Node));
1226       end Process_Node;
1227
1228       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1229       B : Natural renames T.Busy;
1230
1231    --  Start of processing for Iterate
1232
1233    begin
1234       B := B + 1;
1235
1236       begin
1237          Local_Iterate (T, Item);
1238       exception
1239          when others =>
1240             B := B - 1;
1241             raise;
1242       end;
1243
1244       B := B - 1;
1245    end Iterate;
1246
1247    ----------
1248    -- Last --
1249    ----------
1250
1251    function Last (Container : Set) return Cursor is
1252    begin
1253       if Container.Tree.Last = null then
1254          return No_Element;
1255       end if;
1256
1257       return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
1258    end Last;
1259
1260    ------------------
1261    -- Last_Element --
1262    ------------------
1263
1264    function Last_Element (Container : Set) return Element_Type is
1265    begin
1266       if Container.Tree.Last = null then
1267          raise Constraint_Error with "set is empty";
1268       end if;
1269
1270       return Container.Tree.Last.Element;
1271    end Last_Element;
1272
1273    ----------
1274    -- Left --
1275    ----------
1276
1277    function Left (Node : Node_Access) return Node_Access is
1278    begin
1279       return Node.Left;
1280    end Left;
1281
1282    ------------
1283    -- Length --
1284    ------------
1285
1286    function Length (Container : Set) return Count_Type is
1287    begin
1288       return Container.Tree.Length;
1289    end Length;
1290
1291    ----------
1292    -- Move --
1293    ----------
1294
1295    procedure Move is
1296       new Tree_Operations.Generic_Move (Clear);
1297
1298    procedure Move (Target : in out Set; Source : in out Set) is
1299    begin
1300       Move (Target => Target.Tree, Source => Source.Tree);
1301    end Move;
1302
1303    ----------
1304    -- Next --
1305    ----------
1306
1307    procedure Next (Position : in out Cursor)
1308    is
1309    begin
1310       Position := Next (Position);
1311    end Next;
1312
1313    function Next (Position : Cursor) return Cursor is
1314    begin
1315       if Position = No_Element then
1316          return No_Element;
1317       end if;
1318
1319       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1320                      "bad cursor in Next");
1321
1322       declare
1323          Node : constant Node_Access :=
1324                   Tree_Operations.Next (Position.Node);
1325       begin
1326          if Node = null then
1327             return No_Element;
1328          end if;
1329
1330          return Cursor'(Position.Container, Node);
1331       end;
1332    end Next;
1333
1334    -------------
1335    -- Overlap --
1336    -------------
1337
1338    function Overlap (Left, Right : Set) return Boolean is
1339    begin
1340       return Set_Ops.Overlap (Left.Tree, Right.Tree);
1341    end Overlap;
1342
1343    ------------
1344    -- Parent --
1345    ------------
1346
1347    function Parent (Node : Node_Access) return Node_Access is
1348    begin
1349       return Node.Parent;
1350    end Parent;
1351
1352    --------------
1353    -- Previous --
1354    --------------
1355
1356    procedure Previous (Position : in out Cursor)
1357    is
1358    begin
1359       Position := Previous (Position);
1360    end Previous;
1361
1362    function Previous (Position : Cursor) return Cursor is
1363    begin
1364       if Position = No_Element then
1365          return No_Element;
1366       end if;
1367
1368       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1369                      "bad cursor in Previous");
1370
1371       declare
1372          Node : constant Node_Access :=
1373                   Tree_Operations.Previous (Position.Node);
1374       begin
1375          if Node = null then
1376             return No_Element;
1377          end if;
1378
1379          return Cursor'(Position.Container, Node);
1380       end;
1381    end Previous;
1382
1383    -------------------
1384    -- Query_Element --
1385    -------------------
1386
1387    procedure Query_Element
1388      (Position : Cursor;
1389       Process  : not null access procedure (Element : Element_Type))
1390    is
1391    begin
1392       if Position.Node = null then
1393          raise Constraint_Error with "Position cursor equals No_Element";
1394       end if;
1395
1396       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1397                      "bad cursor in Query_Element");
1398
1399       declare
1400          T : Tree_Type renames Position.Container.Tree;
1401
1402          B : Natural renames T.Busy;
1403          L : Natural renames T.Lock;
1404
1405       begin
1406          B := B + 1;
1407          L := L + 1;
1408
1409          begin
1410             Process (Position.Node.Element);
1411          exception
1412             when others =>
1413                L := L - 1;
1414                B := B - 1;
1415                raise;
1416          end;
1417
1418          L := L - 1;
1419          B := B - 1;
1420       end;
1421    end Query_Element;
1422
1423    ----------
1424    -- Read --
1425    ----------
1426
1427    procedure Read
1428      (Stream    : access Root_Stream_Type'Class;
1429       Container : out Set)
1430    is
1431       function Read_Node
1432         (Stream : access Root_Stream_Type'Class) return Node_Access;
1433       pragma Inline (Read_Node);
1434
1435       procedure Read is
1436          new Tree_Operations.Generic_Read (Clear, Read_Node);
1437
1438       ---------------
1439       -- Read_Node --
1440       ---------------
1441
1442       function Read_Node
1443         (Stream : access Root_Stream_Type'Class) return Node_Access
1444       is
1445          Node : Node_Access := new Node_Type;
1446       begin
1447          Element_Type'Read (Stream, Node.Element);
1448          return Node;
1449       exception
1450          when others =>
1451             Free (Node);  --  Note that Free deallocates elem too
1452             raise;
1453       end Read_Node;
1454
1455    --  Start of processing for Read
1456
1457    begin
1458       Read (Stream, Container.Tree);
1459    end Read;
1460
1461    procedure Read
1462      (Stream : access Root_Stream_Type'Class;
1463       Item   : out Cursor)
1464    is
1465    begin
1466       raise Program_Error with "attempt to stream set cursor";
1467    end Read;
1468
1469    ---------------------
1470    -- Replace_Element --
1471    ---------------------
1472
1473    procedure Replace_Element
1474      (Tree : in out Tree_Type;
1475       Node : Node_Access;
1476       Item : Element_Type)
1477    is
1478    begin
1479       if Item < Node.Element
1480         or else Node.Element < Item
1481       then
1482          null;
1483       else
1484          if Tree.Lock > 0 then
1485             raise Program_Error with
1486               "attempt to tamper with cursors (set is locked)";
1487          end if;
1488
1489          Node.Element := Item;
1490          return;
1491       end if;
1492
1493       Tree_Operations.Delete_Node_Sans_Free (Tree, Node);  -- Checks busy-bit
1494
1495       Insert_New_Item : declare
1496          function New_Node return Node_Access;
1497          pragma Inline (New_Node);
1498
1499          procedure Insert_Post is
1500             new Element_Keys.Generic_Insert_Post (New_Node);
1501
1502          procedure Unconditional_Insert is
1503             new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1504
1505          --------------
1506          -- New_Node --
1507          --------------
1508
1509          function New_Node return Node_Access is
1510          begin
1511             Node.Element := Item;
1512             Node.Color := Red_Black_Trees.Red;
1513             Node.Parent := null;
1514             Node.Left := null;
1515             Node.Right := null;
1516
1517             return Node;
1518          end New_Node;
1519
1520          Result : Node_Access;
1521
1522       --  Start of processing for Insert_New_Item
1523
1524       begin
1525          Unconditional_Insert
1526            (Tree => Tree,
1527             Key  => Item,
1528             Node => Result);
1529
1530          pragma Assert (Result = Node);
1531       end Insert_New_Item;
1532    end Replace_Element;
1533
1534    procedure Replace_Element
1535      (Container : in out Set;
1536       Position  : Cursor;
1537       New_Item  : Element_Type)
1538    is
1539    begin
1540       if Position.Node = null then
1541          raise Constraint_Error with
1542            "Position cursor equals No_Element";
1543       end if;
1544
1545       if Position.Container /= Container'Unrestricted_Access then
1546          raise Program_Error with
1547            "Position cursor designates wrong set";
1548       end if;
1549
1550       pragma Assert (Vet (Container.Tree, Position.Node),
1551                      "bad cursor in Replace_Element");
1552
1553       Replace_Element (Container.Tree, Position.Node, New_Item);
1554    end Replace_Element;
1555
1556    ---------------------
1557    -- Reverse_Iterate --
1558    ---------------------
1559
1560    procedure Reverse_Iterate
1561      (Container : Set;
1562       Process   : not null access procedure (Position : Cursor))
1563    is
1564       procedure Process_Node (Node : Node_Access);
1565       pragma Inline (Process_Node);
1566
1567       procedure Local_Reverse_Iterate is
1568         new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1569
1570       ------------------
1571       -- Process_Node --
1572       ------------------
1573
1574       procedure Process_Node (Node : Node_Access) is
1575       begin
1576          Process (Cursor'(Container'Unrestricted_Access, Node));
1577       end Process_Node;
1578
1579       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1580       B : Natural renames T.Busy;
1581
1582    --  Start of processing for Reverse_Iterate
1583
1584    begin
1585       B := B + 1;
1586
1587       begin
1588          Local_Reverse_Iterate (T);
1589       exception
1590          when others =>
1591             B := B - 1;
1592             raise;
1593       end;
1594
1595       B := B - 1;
1596    end Reverse_Iterate;
1597
1598    procedure Reverse_Iterate
1599      (Container : Set;
1600       Item      : Element_Type;
1601       Process   : not null access procedure (Position : Cursor))
1602    is
1603       procedure Process_Node (Node : Node_Access);
1604       pragma Inline (Process_Node);
1605
1606       procedure Local_Reverse_Iterate is
1607          new Element_Keys.Generic_Reverse_Iteration (Process_Node);
1608
1609       ------------------
1610       -- Process_Node --
1611       ------------------
1612
1613       procedure Process_Node (Node : Node_Access) is
1614       begin
1615          Process (Cursor'(Container'Unrestricted_Access, Node));
1616       end Process_Node;
1617
1618       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1619       B : Natural renames T.Busy;
1620
1621    --  Start of processing for Reverse_Iterate
1622
1623    begin
1624       B := B + 1;
1625
1626       begin
1627          Local_Reverse_Iterate (T, Item);
1628       exception
1629          when others =>
1630             B := B - 1;
1631             raise;
1632       end;
1633
1634       B := B - 1;
1635    end Reverse_Iterate;
1636
1637    -----------
1638    -- Right --
1639    -----------
1640
1641    function Right (Node : Node_Access) return Node_Access is
1642    begin
1643       return Node.Right;
1644    end Right;
1645
1646    ---------------
1647    -- Set_Color --
1648    ---------------
1649
1650    procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1651    begin
1652       Node.Color := Color;
1653    end Set_Color;
1654
1655    --------------
1656    -- Set_Left --
1657    --------------
1658
1659    procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1660    begin
1661       Node.Left := Left;
1662    end Set_Left;
1663
1664    ----------------
1665    -- Set_Parent --
1666    ----------------
1667
1668    procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1669    begin
1670       Node.Parent := Parent;
1671    end Set_Parent;
1672
1673    ---------------
1674    -- Set_Right --
1675    ---------------
1676
1677    procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1678    begin
1679       Node.Right := Right;
1680    end Set_Right;
1681
1682    --------------------------
1683    -- Symmetric_Difference --
1684    --------------------------
1685
1686    procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1687    begin
1688       Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1689    end Symmetric_Difference;
1690
1691    function Symmetric_Difference (Left, Right : Set) return Set is
1692       Tree : constant Tree_Type :=
1693                Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1694    begin
1695       return Set'(Controlled with Tree);
1696    end Symmetric_Difference;
1697
1698    ------------
1699    -- To_Set --
1700    ------------
1701
1702    function To_Set (New_Item : Element_Type) return Set is
1703       Tree     : Tree_Type;
1704       Node     : Node_Access;
1705
1706    begin
1707       Insert_Sans_Hint (Tree, New_Item, Node);
1708       return Set'(Controlled with Tree);
1709    end To_Set;
1710
1711    -----------
1712    -- Union --
1713    -----------
1714
1715    procedure Union (Target : in out Set; Source : Set) is
1716    begin
1717       Set_Ops.Union (Target.Tree, Source.Tree);
1718    end Union;
1719
1720    function Union (Left, Right : Set) return Set is
1721       Tree : constant Tree_Type :=
1722                Set_Ops.Union (Left.Tree, Right.Tree);
1723    begin
1724       return Set'(Controlled with Tree);
1725    end Union;
1726
1727    -----------
1728    -- Write --
1729    -----------
1730
1731    procedure Write
1732      (Stream    : access Root_Stream_Type'Class;
1733       Container : Set)
1734    is
1735       procedure Write_Node
1736         (Stream : access Root_Stream_Type'Class;
1737          Node   : Node_Access);
1738       pragma Inline (Write_Node);
1739
1740       procedure Write is
1741          new Tree_Operations.Generic_Write (Write_Node);
1742
1743       ----------------
1744       -- Write_Node --
1745       ----------------
1746
1747       procedure Write_Node
1748         (Stream : access Root_Stream_Type'Class;
1749          Node   : Node_Access)
1750       is
1751       begin
1752          Element_Type'Write (Stream, Node.Element);
1753       end Write_Node;
1754
1755    --  Start of processing for Write
1756
1757    begin
1758       Write (Stream, Container.Tree);
1759    end Write;
1760
1761    procedure Write
1762      (Stream : access Root_Stream_Type'Class;
1763       Item   : Cursor)
1764    is
1765    begin
1766       raise Program_Error with "attempt to stream set cursor";
1767    end Write;
1768
1769 end Ada.Containers.Ordered_Multisets;