gcc/ada/a-ciormu.adb

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