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-2007, 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       pragma Unreferenced (Position);
1056    begin
1057       Insert (Container, New_Item, Position);
1058    end Insert;
1059
1060    procedure Insert
1061      (Container : in out Set;
1062       New_Item  : Element_Type;
1063       Position  : out Cursor)
1064    is
1065    begin
1066       Insert_Sans_Hint (Container.Tree, New_Item, Position.Node);
1067       Position.Container := Container'Unrestricted_Access;
1068    end Insert;
1069
1070    ----------------------
1071    -- Insert_Sans_Hint --
1072    ----------------------
1073
1074    procedure Insert_Sans_Hint
1075      (Tree     : in out Tree_Type;
1076       New_Item : Element_Type;
1077       Node     : out Node_Access)
1078    is
1079       function New_Node return Node_Access;
1080       pragma Inline (New_Node);
1081
1082       procedure Insert_Post is
1083         new Element_Keys.Generic_Insert_Post (New_Node);
1084
1085       procedure Unconditional_Insert is
1086         new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1087
1088       --------------
1089       -- New_Node --
1090       --------------
1091
1092       function New_Node return Node_Access is
1093          Element : Element_Access := new Element_Type'(New_Item);
1094
1095       begin
1096          return new Node_Type'(Parent  => null,
1097                                Left    => null,
1098                                Right   => null,
1099                                Color   => Red_Black_Trees.Red,
1100                                Element => Element);
1101       exception
1102          when others =>
1103             Free_Element (Element);
1104             raise;
1105       end New_Node;
1106
1107    --  Start of processing for Insert_Sans_Hint
1108
1109    begin
1110       Unconditional_Insert (Tree, New_Item, Node);
1111    end Insert_Sans_Hint;
1112
1113    ----------------------
1114    -- Insert_With_Hint --
1115    ----------------------
1116
1117    procedure Insert_With_Hint
1118      (Dst_Tree : in out Tree_Type;
1119       Dst_Hint : Node_Access;
1120       Src_Node : Node_Access;
1121       Dst_Node : out Node_Access)
1122    is
1123       function New_Node return Node_Access;
1124       pragma Inline (New_Node);
1125
1126       procedure Insert_Post is
1127         new Element_Keys.Generic_Insert_Post (New_Node);
1128
1129       procedure Insert_Sans_Hint is
1130         new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1131
1132       procedure Local_Insert_With_Hint is
1133         new Element_Keys.Generic_Unconditional_Insert_With_Hint
1134           (Insert_Post,
1135            Insert_Sans_Hint);
1136
1137       --------------
1138       -- New_Node --
1139       --------------
1140
1141       function New_Node return Node_Access is
1142          X : Element_Access := new Element_Type'(Src_Node.Element.all);
1143
1144       begin
1145          return new Node_Type'(Parent  => null,
1146                                Left    => null,
1147                                Right   => null,
1148                                Color   => Red,
1149                                Element => X);
1150
1151       exception
1152          when others =>
1153             Free_Element (X);
1154             raise;
1155       end New_Node;
1156
1157    --  Start of processing for Insert_With_Hint
1158
1159    begin
1160       Local_Insert_With_Hint
1161         (Dst_Tree,
1162          Dst_Hint,
1163          Src_Node.Element.all,
1164          Dst_Node);
1165    end Insert_With_Hint;
1166
1167    ------------------
1168    -- Intersection --
1169    ------------------
1170
1171    procedure Intersection (Target : in out Set; Source : Set) is
1172    begin
1173       Set_Ops.Intersection (Target.Tree, Source.Tree);
1174    end Intersection;
1175
1176    function Intersection (Left, Right : Set) return Set is
1177       Tree : constant Tree_Type :=
1178                Set_Ops.Intersection (Left.Tree, Right.Tree);
1179    begin
1180       return Set'(Controlled with Tree);
1181    end Intersection;
1182
1183    --------------
1184    -- Is_Empty --
1185    --------------
1186
1187    function Is_Empty (Container : Set) return Boolean is
1188    begin
1189       return Container.Tree.Length = 0;
1190    end Is_Empty;
1191
1192    ------------------------
1193    -- Is_Equal_Node_Node --
1194    ------------------------
1195
1196    function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1197    begin
1198       return L.Element.all = R.Element.all;
1199    end Is_Equal_Node_Node;
1200
1201    -----------------------------
1202    -- Is_Greater_Element_Node --
1203    -----------------------------
1204
1205    function Is_Greater_Element_Node
1206      (Left  : Element_Type;
1207       Right : Node_Access) return Boolean
1208    is
1209    begin
1210       --  e > node same as node < e
1211
1212       return Right.Element.all < Left;
1213    end Is_Greater_Element_Node;
1214
1215    --------------------------
1216    -- Is_Less_Element_Node --
1217    --------------------------
1218
1219    function Is_Less_Element_Node
1220      (Left  : Element_Type;
1221       Right : Node_Access) return Boolean
1222    is
1223    begin
1224       return Left < Right.Element.all;
1225    end Is_Less_Element_Node;
1226
1227    -----------------------
1228    -- Is_Less_Node_Node --
1229    -----------------------
1230
1231    function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1232    begin
1233       return L.Element.all < R.Element.all;
1234    end Is_Less_Node_Node;
1235
1236    ---------------
1237    -- Is_Subset --
1238    ---------------
1239
1240    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1241    begin
1242       return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1243    end Is_Subset;
1244
1245    -------------
1246    -- Iterate --
1247    -------------
1248
1249    procedure Iterate
1250      (Container : Set;
1251       Item      : Element_Type;
1252       Process   : not null access procedure (Position : Cursor))
1253    is
1254       procedure Process_Node (Node : Node_Access);
1255       pragma Inline (Process_Node);
1256
1257       procedure Local_Iterate is
1258         new Element_Keys.Generic_Iteration (Process_Node);
1259
1260       ------------------
1261       -- Process_Node --
1262       ------------------
1263
1264       procedure Process_Node (Node : Node_Access) is
1265       begin
1266          Process (Cursor'(Container'Unrestricted_Access, Node));
1267       end Process_Node;
1268
1269       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1270       B : Natural renames T.Busy;
1271
1272    --  Start of processing for Iterate
1273
1274    begin
1275       B := B + 1;
1276
1277       begin
1278          Local_Iterate (T, Item);
1279       exception
1280          when others =>
1281             B := B - 1;
1282             raise;
1283       end;
1284
1285       B := B - 1;
1286    end Iterate;
1287
1288    procedure Iterate
1289      (Container : Set;
1290       Process   : not null access procedure (Position : Cursor))
1291    is
1292       procedure Process_Node (Node : Node_Access);
1293       pragma Inline (Process_Node);
1294
1295       procedure Local_Iterate is
1296         new Tree_Operations.Generic_Iteration (Process_Node);
1297
1298       ------------------
1299       -- Process_Node --
1300       ------------------
1301
1302       procedure Process_Node (Node : Node_Access) is
1303       begin
1304          Process (Cursor'(Container'Unrestricted_Access, Node));
1305       end Process_Node;
1306
1307       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1308       B : Natural renames T.Busy;
1309
1310    --  Start of processing for Iterate
1311
1312    begin
1313       B := B + 1;
1314
1315       begin
1316          Local_Iterate (T);
1317       exception
1318          when others =>
1319             B := B - 1;
1320             raise;
1321       end;
1322
1323       B := B - 1;
1324    end Iterate;
1325
1326    ----------
1327    -- Last --
1328    ----------
1329
1330    function Last (Container : Set) return Cursor is
1331    begin
1332       if Container.Tree.Last = null then
1333          return No_Element;
1334       end if;
1335
1336       return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
1337    end Last;
1338
1339    ------------------
1340    -- Last_Element --
1341    ------------------
1342
1343    function Last_Element (Container : Set) return Element_Type is
1344    begin
1345       if Container.Tree.Last = null then
1346          raise Constraint_Error with "set is empty";
1347       end if;
1348
1349       pragma Assert (Container.Tree.Last.Element /= null);
1350       return Container.Tree.Last.Element.all;
1351    end Last_Element;
1352
1353    ----------
1354    -- Left --
1355    ----------
1356
1357    function Left (Node : Node_Access) return Node_Access is
1358    begin
1359       return Node.Left;
1360    end Left;
1361
1362    ------------
1363    -- Length --
1364    ------------
1365
1366    function Length (Container : Set) return Count_Type is
1367    begin
1368       return Container.Tree.Length;
1369    end Length;
1370
1371    ----------
1372    -- Move --
1373    ----------
1374
1375    procedure Move is
1376       new Tree_Operations.Generic_Move (Clear);
1377
1378    procedure Move (Target : in out Set; Source : in out Set) is
1379    begin
1380       Move (Target => Target.Tree, Source => Source.Tree);
1381    end Move;
1382
1383    ----------
1384    -- Next --
1385    ----------
1386
1387    function Next (Position : Cursor) return Cursor is
1388    begin
1389       if Position = No_Element then
1390          return No_Element;
1391       end if;
1392
1393       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1394                      "bad cursor in Next");
1395
1396       declare
1397          Node : constant Node_Access :=
1398                   Tree_Operations.Next (Position.Node);
1399
1400       begin
1401          if Node = null then
1402             return No_Element;
1403          end if;
1404
1405          return Cursor'(Position.Container, Node);
1406       end;
1407    end Next;
1408
1409    procedure Next (Position : in out Cursor) is
1410    begin
1411       Position := Next (Position);
1412    end Next;
1413
1414    -------------
1415    -- Overlap --
1416    -------------
1417
1418    function Overlap (Left, Right : Set) return Boolean is
1419    begin
1420       return Set_Ops.Overlap (Left.Tree, Right.Tree);
1421    end Overlap;
1422
1423    ------------
1424    -- Parent --
1425    ------------
1426
1427    function Parent (Node : Node_Access) return Node_Access is
1428    begin
1429       return Node.Parent;
1430    end Parent;
1431
1432    --------------
1433    -- Previous --
1434    --------------
1435
1436    function Previous (Position : Cursor) return Cursor is
1437    begin
1438       if Position = No_Element then
1439          return No_Element;
1440       end if;
1441
1442       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1443                      "bad cursor in Previous");
1444
1445       declare
1446          Node : constant Node_Access :=
1447                   Tree_Operations.Previous (Position.Node);
1448
1449       begin
1450          if Node = null then
1451             return No_Element;
1452          end if;
1453
1454          return Cursor'(Position.Container, Node);
1455       end;
1456    end Previous;
1457
1458    procedure Previous (Position : in out Cursor) is
1459    begin
1460       Position := Previous (Position);
1461    end Previous;
1462
1463    -------------------
1464    -- Query_Element --
1465    -------------------
1466
1467    procedure Query_Element
1468      (Position : Cursor;
1469       Process  : not null access procedure (Element : Element_Type))
1470    is
1471    begin
1472       if Position.Node = null then
1473          raise Constraint_Error with "Position cursor equals No_Element";
1474       end if;
1475
1476       if Position.Node.Element = null then
1477          raise Program_Error with "Position cursor is bad";
1478       end if;
1479
1480       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1481                      "bad cursor in Query_Element");
1482
1483       declare
1484          T : Tree_Type renames Position.Container.Tree;
1485
1486          B : Natural renames T.Busy;
1487          L : Natural renames T.Lock;
1488
1489       begin
1490          B := B + 1;
1491          L := L + 1;
1492
1493          begin
1494             Process (Position.Node.Element.all);
1495          exception
1496             when others =>
1497                L := L - 1;
1498                B := B - 1;
1499                raise;
1500          end;
1501
1502          L := L - 1;
1503          B := B - 1;
1504       end;
1505    end Query_Element;
1506
1507    ----------
1508    -- Read --
1509    ----------
1510
1511    procedure Read
1512      (Stream    : not null access Root_Stream_Type'Class;
1513       Container : out Set)
1514    is
1515       function Read_Node
1516         (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1517       pragma Inline (Read_Node);
1518
1519       procedure Read is
1520          new Tree_Operations.Generic_Read (Clear, Read_Node);
1521
1522       ---------------
1523       -- Read_Node --
1524       ---------------
1525
1526       function Read_Node
1527         (Stream : not null access Root_Stream_Type'Class) return Node_Access
1528       is
1529          Node : Node_Access := new Node_Type;
1530       begin
1531          Node.Element := new Element_Type'(Element_Type'Input (Stream));
1532          return Node;
1533       exception
1534          when others =>
1535             Free (Node);  --  Note that Free deallocates elem too
1536             raise;
1537       end Read_Node;
1538
1539    --  Start of processing for Read
1540
1541    begin
1542       Read (Stream, Container.Tree);
1543    end Read;
1544
1545    procedure Read
1546      (Stream : not null access Root_Stream_Type'Class;
1547       Item   : out Cursor)
1548    is
1549    begin
1550       raise Program_Error with "attempt to stream set cursor";
1551    end Read;
1552
1553    ---------------------
1554    -- Replace_Element --
1555    ---------------------
1556
1557    procedure Replace_Element
1558      (Tree : in out Tree_Type;
1559       Node : Node_Access;
1560       Item : Element_Type)
1561    is
1562    begin
1563       if Item < Node.Element.all
1564         or else Node.Element.all < Item
1565       then
1566          null;
1567       else
1568          if Tree.Lock > 0 then
1569             raise Program_Error with
1570               "attempt to tamper with cursors (set is locked)";
1571          end if;
1572
1573          declare
1574             X : Element_Access := Node.Element;
1575          begin
1576             Node.Element := new Element_Type'(Item);
1577             Free_Element (X);
1578          end;
1579
1580          return;
1581       end if;
1582
1583       Tree_Operations.Delete_Node_Sans_Free (Tree, Node);  -- Checks busy-bit
1584
1585       Insert_New_Item : declare
1586          function New_Node return Node_Access;
1587          pragma Inline (New_Node);
1588
1589          procedure Insert_Post is
1590             new Element_Keys.Generic_Insert_Post (New_Node);
1591
1592          procedure Unconditional_Insert is
1593             new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1594
1595          --------------
1596          -- New_Node --
1597          --------------
1598
1599          function New_Node return Node_Access is
1600          begin
1601             Node.Element := new Element_Type'(Item);  -- OK if fails
1602             Node.Color := Red_Black_Trees.Red;
1603             Node.Parent := null;
1604             Node.Left := null;
1605             Node.Right := null;
1606
1607             return Node;
1608          end New_Node;
1609
1610          Result : Node_Access;
1611
1612          X : Element_Access := Node.Element;
1613
1614       --  Start of processing for Insert_New_Item
1615
1616       begin
1617          Unconditional_Insert
1618            (Tree => Tree,
1619             Key  => Item,
1620             Node => Result);
1621          pragma Assert (Result = Node);
1622
1623          Free_Element (X);  -- OK if fails
1624       end Insert_New_Item;
1625    end Replace_Element;
1626
1627    procedure Replace_Element
1628     (Container : in out Set;
1629      Position  : Cursor;
1630      New_Item  : Element_Type)
1631    is
1632    begin
1633       if Position.Node = null then
1634          raise Constraint_Error with "Position cursor equals No_Element";
1635       end if;
1636
1637       if Position.Node.Element = null then
1638          raise Program_Error with "Position cursor is bad";
1639       end if;
1640
1641       if Position.Container /= Container'Unrestricted_Access then
1642          raise Program_Error with "Position cursor designates wrong set";
1643       end if;
1644
1645       pragma Assert (Vet (Container.Tree, Position.Node),
1646                      "bad cursor in Replace_Element");
1647
1648       Replace_Element (Container.Tree, Position.Node, New_Item);
1649    end Replace_Element;
1650
1651    ---------------------
1652    -- Reverse_Iterate --
1653    ---------------------
1654
1655    procedure Reverse_Iterate
1656      (Container : Set;
1657       Item      : Element_Type;
1658       Process   : not null access procedure (Position : Cursor))
1659    is
1660       procedure Process_Node (Node : Node_Access);
1661       pragma Inline (Process_Node);
1662
1663       procedure Local_Reverse_Iterate is
1664         new Element_Keys.Generic_Reverse_Iteration (Process_Node);
1665
1666       ------------------
1667       -- Process_Node --
1668       ------------------
1669
1670       procedure Process_Node (Node : Node_Access) is
1671       begin
1672          Process (Cursor'(Container'Unrestricted_Access, Node));
1673       end Process_Node;
1674
1675       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1676       B : Natural renames T.Busy;
1677
1678    --  Start of processing for Reverse_Iterate
1679
1680    begin
1681       B := B + 1;
1682
1683       begin
1684          Local_Reverse_Iterate (T, Item);
1685       exception
1686          when others =>
1687             B := B - 1;
1688             raise;
1689       end;
1690
1691       B := B - 1;
1692    end Reverse_Iterate;
1693
1694    procedure Reverse_Iterate
1695      (Container : Set;
1696       Process   : not null access procedure (Position : Cursor))
1697    is
1698       procedure Process_Node (Node : Node_Access);
1699       pragma Inline (Process_Node);
1700
1701       procedure Local_Reverse_Iterate is
1702         new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1703
1704       ------------------
1705       -- Process_Node --
1706       ------------------
1707
1708       procedure Process_Node (Node : Node_Access) is
1709       begin
1710          Process (Cursor'(Container'Unrestricted_Access, Node));
1711       end Process_Node;
1712
1713       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1714       B : Natural renames T.Busy;
1715
1716    --  Start of processing for Reverse_Iterate
1717
1718    begin
1719       B := B + 1;
1720
1721       begin
1722          Local_Reverse_Iterate (T);
1723       exception
1724          when others =>
1725             B := B - 1;
1726             raise;
1727       end;
1728
1729       B := B - 1;
1730    end Reverse_Iterate;
1731
1732    -----------
1733    -- Right --
1734    -----------
1735
1736    function Right (Node : Node_Access) return Node_Access is
1737    begin
1738       return Node.Right;
1739    end Right;
1740
1741    ---------------
1742    -- Set_Color --
1743    ---------------
1744
1745    procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1746    begin
1747       Node.Color := Color;
1748    end Set_Color;
1749
1750    --------------
1751    -- Set_Left --
1752    --------------
1753
1754    procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1755    begin
1756       Node.Left := Left;
1757    end Set_Left;
1758
1759    ----------------
1760    -- Set_Parent --
1761    ----------------
1762
1763    procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1764    begin
1765       Node.Parent := Parent;
1766    end Set_Parent;
1767
1768    ---------------
1769    -- Set_Right --
1770    ---------------
1771
1772    procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1773    begin
1774       Node.Right := Right;
1775    end Set_Right;
1776
1777    --------------------------
1778    -- Symmetric_Difference --
1779    --------------------------
1780
1781    procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1782    begin
1783       Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1784    end Symmetric_Difference;
1785
1786    function Symmetric_Difference (Left, Right : Set) return Set is
1787       Tree : constant Tree_Type :=
1788                Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1789    begin
1790       return Set'(Controlled with Tree);
1791    end Symmetric_Difference;
1792
1793    ------------
1794    -- To_Set --
1795    ------------
1796
1797    function To_Set (New_Item : Element_Type) return Set is
1798       Tree : Tree_Type;
1799       Node : Node_Access;
1800       pragma Unreferenced (Node);
1801    begin
1802       Insert_Sans_Hint (Tree, New_Item, Node);
1803       return Set'(Controlled with Tree);
1804    end To_Set;
1805
1806    -----------
1807    -- Union --
1808    -----------
1809
1810    procedure Union (Target : in out Set; Source : Set) is
1811    begin
1812       Set_Ops.Union (Target.Tree, Source.Tree);
1813    end Union;
1814
1815    function Union (Left, Right : Set) return Set is
1816       Tree : constant Tree_Type :=
1817                Set_Ops.Union (Left.Tree, Right.Tree);
1818    begin
1819       return Set'(Controlled with Tree);
1820    end Union;
1821
1822    -----------
1823    -- Write --
1824    -----------
1825
1826    procedure Write
1827      (Stream    : not null access Root_Stream_Type'Class;
1828       Container : Set)
1829    is
1830       procedure Write_Node
1831         (Stream : not null access Root_Stream_Type'Class;
1832          Node   : Node_Access);
1833       pragma Inline (Write_Node);
1834
1835       procedure Write is
1836          new Tree_Operations.Generic_Write (Write_Node);
1837
1838       ----------------
1839       -- Write_Node --
1840       ----------------
1841
1842       procedure Write_Node
1843         (Stream : not null access Root_Stream_Type'Class;
1844          Node   : Node_Access)
1845       is
1846       begin
1847          Element_Type'Output (Stream, Node.Element.all);
1848       end Write_Node;
1849
1850    --  Start of processing for Write
1851
1852    begin
1853       Write (Stream, Container.Tree);
1854    end Write;
1855
1856    procedure Write
1857      (Stream : not null access Root_Stream_Type'Class;
1858       Item   : Cursor)
1859    is
1860    begin
1861       raise Program_Error with "attempt to stream set cursor";
1862    end Write;
1863
1864 end Ada.Containers.Indefinite_Ordered_Multisets;