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