gcc/ada/a-ciorse.adb

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