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