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