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