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