gcc/ada/a-ciormu.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --               ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2007, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- This unit was originally developed by Matthew J Heaney.                  --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Unchecked_Deallocation;
  33
  34 with Ada.Containers.Red_Black_Trees.Generic_Operations;
  35 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
  36
  37 with Ada.Containers.Red_Black_Trees.Generic_Keys;
  38 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
  39
  40 with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
  41 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
  42
  43 package body Ada.Containers.Indefinite_Ordered_Multisets is
  44
  45    -----------------------------
  46    -- Node Access Subprograms --
  47    -----------------------------
  48
  49    --  These subprograms provide a functional interface to access fields
  50    --  of a node, and a procedural interface for modifying these values.
  51
  52    function Color (Node : Node_Access) return Color_Type;
  53    pragma Inline (Color);
  54
  55    function Left (Node : Node_Access) return Node_Access;
  56    pragma Inline (Left);
  57
  58    function Parent (Node : Node_Access) return Node_Access;
  59    pragma Inline (Parent);
  60
  61    function Right (Node : Node_Access) return Node_Access;
  62    pragma Inline (Right);
  63
  64    procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
  65    pragma Inline (Set_Parent);
  66
  67    procedure Set_Left (Node : Node_Access; Left : Node_Access);
  68    pragma Inline (Set_Left);
  69
  70    procedure Set_Right (Node : Node_Access; Right : Node_Access);
  71    pragma Inline (Set_Right);
  72
  73    procedure Set_Color (Node : Node_Access; Color : Color_Type);
  74    pragma Inline (Set_Color);
  75
  76    -----------------------
  77    -- Local Subprograms --
  78    -----------------------
  79
  80    function Copy_Node (Source : Node_Access) return Node_Access;
  81    pragma Inline (Copy_Node);
  82
  83    procedure Free (X : in out Node_Access);
  84
  85    procedure Insert_Sans_Hint
  86      (Tree     : in out Tree_Type;
  87       New_Item : Element_Type;
  88       Node     : out Node_Access);
  89
  90    procedure Insert_With_Hint
  91      (Dst_Tree : in out Tree_Type;
  92       Dst_Hint : Node_Access;
  93       Src_Node : Node_Access;
  94       Dst_Node : out Node_Access);
  95
  96    function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
  97    pragma Inline (Is_Equal_Node_Node);
  98
  99    function Is_Greater_Element_Node
 100      (Left  : Element_Type;
 101       Right : Node_Access) return Boolean;
 102    pragma Inline (Is_Greater_Element_Node);
 103
 104    function Is_Less_Element_Node
 105      (Left  : Element_Type;
 106       Right : Node_Access) return Boolean;
 107    pragma Inline (Is_Less_Element_Node);
 108
 109    function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
 110    pragma Inline (Is_Less_Node_Node);
 111
 112    procedure Replace_Element
 113      (Tree : in out Tree_Type;
 114       Node : Node_Access;
 115       Item : Element_Type);
 116
 117    --------------------------
 118    -- Local Instantiations --
 119    --------------------------
 120
 121    package Tree_Operations is
 122      new Red_Black_Trees.Generic_Operations (Tree_Types);
 123
 124    procedure Delete_Tree is
 125      new Tree_Operations.Generic_Delete_Tree (Free);
 126
 127    function Copy_Tree is
 128      new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
 129
 130    use Tree_Operations;
 131
 132    procedure Free_Element is
 133      new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
 134
 135    function Is_Equal is
 136      new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
 137
 138    package Set_Ops is
 139      new Generic_Set_Operations
 140        (Tree_Operations  => Tree_Operations,
 141         Insert_With_Hint => Insert_With_Hint,
 142         Copy_Tree        => Copy_Tree,
 143         Delete_Tree      => Delete_Tree,
 144         Is_Less          => Is_Less_Node_Node,
 145         Free             => Free);
 146
 147    package Element_Keys is
 148      new Red_Black_Trees.Generic_Keys
 149        (Tree_Operations     => Tree_Operations,
 150         Key_Type            => Element_Type,
 151         Is_Less_Key_Node    => Is_Less_Element_Node,
 152         Is_Greater_Key_Node => Is_Greater_Element_Node);
 153
 154    ---------
 155    -- "<" --
 156    ---------
 157
 158    function "<" (Left, Right : Cursor) return Boolean is
 159    begin
 160       if Left.Node = null then
 161          raise Constraint_Error with "Left cursor equals No_Element";
 162       end if;
 163
 164       if Right.Node = null then
 165          raise Constraint_Error with "Right cursor equals No_Element";
 166       end if;
 167
 168       if Left.Node.Element = null then
 169          raise Program_Error with "Left cursor is bad";
 170       end if;
 171
 172       if Right.Node.Element = null then
 173          raise Program_Error with "Right cursor is bad";
 174       end if;
 175
 176       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 177                      "bad Left cursor in ""<""");
 178
 179       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 180                      "bad Right cursor in ""<""");
 181
 182       return Left.Node.Element.all < Right.Node.Element.all;
 183    end "<";
 184
 185    function "<" (Left : Cursor; Right : Element_Type) return Boolean is
 186    begin
 187       if Left.Node = null then
 188          raise Constraint_Error with "Left cursor equals No_Element";
 189       end if;
 190
 191       if Left.Node.Element = null then
 192          raise Program_Error with "Left cursor is bad";
 193       end if;
 194
 195       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 196                      "bad Left cursor in ""<""");
 197
 198       return Left.Node.Element.all < Right;
 199    end "<";
 200
 201    function "<" (Left : Element_Type; Right : Cursor) return Boolean is
 202    begin
 203       if Right.Node = null then
 204          raise Constraint_Error with "Right cursor equals No_Element";
 205       end if;
 206
 207       if Right.Node.Element = null then
 208          raise Program_Error with "Right cursor is bad";
 209       end if;
 210
 211       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 212                      "bad Right cursor in ""<""");
 213
 214       return Left < Right.Node.Element.all;
 215    end "<";
 216
 217    ---------
 218    -- "=" --
 219    ---------
 220
 221    function "=" (Left, Right : Set) return Boolean is
 222    begin
 223       return Is_Equal (Left.Tree, Right.Tree);
 224    end "=";
 225
 226    ---------
 227    -- ">" --
 228    ---------
 229
 230    function ">" (Left, Right : Cursor) return Boolean is
 231    begin
 232       if Left.Node = null then
 233          raise Constraint_Error with "Left cursor equals No_Element";
 234       end if;
 235
 236       if Right.Node = null then
 237          raise Constraint_Error with "Right cursor equals No_Element";
 238       end if;
 239
 240       if Left.Node.Element = null then
 241          raise Program_Error with "Left cursor is bad";
 242       end if;
 243
 244       if Right.Node.Element = null then
 245          raise Program_Error with "Right cursor is bad";
 246       end if;
 247
 248       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 249                      "bad Left cursor in "">""");
 250
 251       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 252                      "bad Right cursor in "">""");
 253
 254       --  L > R same as R < L
 255
 256       return Right.Node.Element.all < Left.Node.Element.all;
 257    end ">";
 258
 259    function ">" (Left : Cursor; Right : Element_Type) return Boolean is
 260    begin
 261       if Left.Node = null then
 262          raise Constraint_Error with "Left cursor equals No_Element";
 263       end if;
 264
 265       if Left.Node.Element = null then
 266          raise Program_Error with "Left cursor is bad";
 267       end if;
 268
 269       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 270                      "bad Left cursor in "">""");
 271
 272       return Right < Left.Node.Element.all;
 273    end ">";
 274
 275    function ">" (Left : Element_Type; Right : Cursor) return Boolean is
 276    begin
 277       if Right.Node = null then
 278          raise Constraint_Error with "Right cursor equals No_Element";
 279       end if;
 280
 281       if Right.Node.Element = null then
 282          raise Program_Error with "Right cursor is bad";
 283       end if;
 284
 285       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 286                      "bad Right cursor in "">""");
 287
 288       return Right.Node.Element.all < Left;
 289    end ">";
 290
 291    ------------
 292    -- Adjust --
 293    ------------
 294
 295    procedure Adjust is
 296       new Tree_Operations.Generic_Adjust (Copy_Tree);
 297
 298    procedure Adjust (Container : in out Set) is
 299    begin
 300       Adjust (Container.Tree);
 301    end Adjust;
 302
 303    -------------
 304    -- Ceiling --
 305    -------------
 306
 307    function Ceiling (Container : Set; Item : Element_Type) return Cursor is
 308       Node : constant Node_Access :=
 309                Element_Keys.Ceiling (Container.Tree, Item);
 310
 311    begin
 312       if Node = null then
 313          return No_Element;
 314       end if;
 315
 316       return Cursor'(Container'Unrestricted_Access, Node);
 317    end Ceiling;
 318
 319    -----------
 320    -- Clear --
 321    -----------
 322
 323    procedure Clear is
 324       new Tree_Operations.Generic_Clear (Delete_Tree);
 325
 326    procedure Clear (Container : in out Set) is
 327    begin
 328       Clear (Container.Tree);
 329    end Clear;
 330
 331    -----------
 332    -- Color --
 333    -----------
 334
 335    function Color (Node : Node_Access) return Color_Type is
 336    begin
 337       return Node.Color;
 338    end Color;
 339
 340    --------------
 341    -- Contains --
 342    --------------
 343
 344    function Contains (Container : Set; Item : Element_Type) return Boolean is
 345    begin
 346       return Find (Container, Item) /= No_Element;
 347    end Contains;
 348
 349    ---------------
 350    -- Copy_Node --
 351    ---------------
 352
 353    function Copy_Node (Source : Node_Access) return Node_Access is
 354       X : Element_Access := new Element_Type'(Source.Element.all);
 355
 356    begin
 357       return new Node_Type'(Parent  => null,
 358                             Left    => null,
 359                             Right   => null,
 360                             Color   => Source.Color,
 361                             Element => X);
 362
 363    exception
 364       when others =>
 365          Free_Element (X);
 366          raise;
 367    end Copy_Node;
 368
 369    ------------
 370    -- Delete --
 371    ------------
 372
 373    procedure Delete (Container : in out Set; Item : Element_Type) is
 374       Tree : Tree_Type renames Container.Tree;
 375       Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
 376       Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
 377       X    : Node_Access;
 378
 379    begin
 380       if Node = Done then
 381          raise Constraint_Error with "attempt to delete element not in set";
 382       end if;
 383
 384       loop
 385          X := Node;
 386          Node := Tree_Operations.Next (Node);
 387          Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 388          Free (X);
 389
 390          exit when Node = Done;
 391       end loop;
 392    end Delete;
 393
 394    procedure Delete (Container : in out Set; Position : in out Cursor) is
 395    begin
 396       if Position.Node = null then
 397          raise Constraint_Error with "Position cursor equals No_Element";
 398       end if;
 399
 400       if Position.Node.Element = null then
 401          raise Program_Error with "Position cursor is bad";
 402       end if;
 403
 404       if Position.Container /= Container'Unrestricted_Access then
 405          raise Program_Error with "Position cursor designates wrong set";
 406       end if;
 407
 408       pragma Assert (Vet (Container.Tree, Position.Node),
 409                      "bad cursor in Delete");
 410
 411       Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
 412       Free (Position.Node);
 413
 414       Position.Container := null;
 415    end Delete;
 416
 417    ------------------
 418    -- Delete_First --
 419    ------------------
 420
 421    procedure Delete_First (Container : in out Set) is
 422       Tree : Tree_Type renames Container.Tree;
 423       X    : Node_Access := Tree.First;
 424
 425    begin
 426       if X = null then
 427          return;
 428       end if;
 429
 430       Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 431       Free (X);
 432    end Delete_First;
 433
 434    -----------------
 435    -- Delete_Last --
 436    -----------------
 437
 438    procedure Delete_Last (Container : in out Set) is
 439       Tree : Tree_Type renames Container.Tree;
 440       X    : Node_Access := Tree.Last;
 441
 442    begin
 443       if X = null then
 444          return;
 445       end if;
 446
 447       Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 448       Free (X);
 449    end Delete_Last;
 450
 451    ----------------
 452    -- Difference --
 453    ----------------
 454
 455    procedure Difference (Target : in out Set; Source : Set) is
 456    begin
 457       Set_Ops.Difference (Target.Tree, Source.Tree);
 458    end Difference;
 459
 460    function Difference (Left, Right : Set) return Set is
 461       Tree : constant Tree_Type :=
 462                Set_Ops.Difference (Left.Tree, Right.Tree);
 463    begin
 464       return Set'(Controlled with Tree);
 465    end Difference;
 466
 467    -------------
 468    -- Element --
 469    -------------
 470
 471    function Element (Position : Cursor) return Element_Type is
 472    begin
 473       if Position.Node = null then
 474          raise Constraint_Error with "Position cursor equals No_Element";
 475       end if;
 476
 477       if Position.Node.Element = null then
 478          raise Program_Error with "Position cursor is bad";
 479       end if;
 480
 481       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 482                      "bad cursor in Element");
 483
 484       return Position.Node.Element.all;
 485    end Element;
 486
 487    -------------------------
 488    -- Equivalent_Elements --
 489    -------------------------
 490
 491    function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
 492    begin
 493       if Left < Right
 494         or else Right < Left
 495       then
 496          return False;
 497       else
 498          return True;
 499       end if;
 500    end Equivalent_Elements;
 501
 502    ---------------------
 503    -- Equivalent_Sets --
 504    ---------------------
 505
 506    function Equivalent_Sets (Left, Right : Set) return Boolean is
 507
 508       function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
 509       pragma Inline (Is_Equivalent_Node_Node);
 510
 511       function Is_Equivalent is
 512          new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
 513
 514       -----------------------------
 515       -- Is_Equivalent_Node_Node --
 516       -----------------------------
 517
 518       function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
 519       begin
 520          if L.Element.all < R.Element.all then
 521             return False;
 522          elsif R.Element.all < L.Element.all then
 523             return False;
 524          else
 525             return True;
 526          end if;
 527       end Is_Equivalent_Node_Node;
 528
 529    --  Start of processing for Equivalent_Sets
 530
 531    begin
 532       return Is_Equivalent (Left.Tree, Right.Tree);
 533    end Equivalent_Sets;
 534
 535    -------------
 536    -- Exclude --
 537    -------------
 538
 539    procedure Exclude (Container : in out Set; Item : Element_Type) is
 540       Tree : Tree_Type renames Container.Tree;
 541       Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
 542       Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
 543       X    : Node_Access;
 544
 545    begin
 546       while Node /= Done loop
 547          X := Node;
 548          Node := Tree_Operations.Next (Node);
 549          Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 550          Free (X);
 551       end loop;
 552    end Exclude;
 553
 554    ----------
 555    -- Find --
 556    ----------
 557
 558    function Find (Container : Set; Item : Element_Type) return Cursor is
 559       Node : constant Node_Access :=
 560                Element_Keys.Find (Container.Tree, Item);
 561
 562    begin
 563       if Node = null then
 564          return No_Element;
 565       end if;
 566
 567       return Cursor'(Container'Unrestricted_Access, Node);
 568    end Find;
 569
 570    -----------
 571    -- First --
 572    -----------
 573
 574    function First (Container : Set) return Cursor is
 575    begin
 576       if Container.Tree.First = null then
 577          return No_Element;
 578       end if;
 579
 580       return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
 581    end First;
 582
 583    -------------------
 584    -- First_Element --
 585    -------------------
 586
 587    function First_Element (Container : Set) return Element_Type is
 588    begin
 589       if Container.Tree.First = null then
 590          raise Constraint_Error with "set is empty";
 591       end if;
 592
 593       pragma Assert (Container.Tree.First.Element /= null);
 594       return Container.Tree.First.Element.all;
 595    end First_Element;
 596
 597    -----------
 598    -- Floor --
 599    -----------
 600
 601    function Floor (Container : Set; Item : Element_Type) return Cursor is
 602       Node : constant Node_Access :=
 603                Element_Keys.Floor (Container.Tree, Item);
 604
 605    begin
 606       if Node = null then
 607          return No_Element;
 608       end if;
 609
 610       return Cursor'(Container'Unrestricted_Access, Node);
 611    end Floor;
 612
 613    ----------
 614    -- Free --
 615    ----------
 616
 617    procedure Free (X : in out Node_Access) is
 618       procedure Deallocate is
 619         new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 620
 621    begin
 622       if X = null then
 623          return;
 624       end if;
 625
 626       X.Parent := X;
 627       X.Left := X;
 628       X.Right := X;
 629
 630       begin
 631          Free_Element (X.Element);
 632       exception
 633          when others =>
 634             X.Element := null;
 635             Deallocate (X);
 636             raise;
 637       end;
 638
 639       Deallocate (X);
 640    end Free;
 641
 642    ------------------
 643    -- Generic_Keys --
 644    ------------------
 645
 646    package body Generic_Keys is
 647
 648       -----------------------
 649       -- Local Subprograms --
 650       -----------------------
 651
 652       function Is_Less_Key_Node
 653         (Left  : Key_Type;
 654          Right : Node_Access) return Boolean;
 655       pragma Inline (Is_Less_Key_Node);
 656
 657       function Is_Greater_Key_Node
 658         (Left  : Key_Type;
 659          Right : Node_Access) return Boolean;
 660       pragma Inline (Is_Greater_Key_Node);
 661
 662       --------------------------
 663       -- Local Instantiations --
 664       --------------------------
 665
 666       package Key_Keys is
 667         new Red_Black_Trees.Generic_Keys
 668           (Tree_Operations     => Tree_Operations,
 669            Key_Type            => Key_Type,
 670            Is_Less_Key_Node    => Is_Less_Key_Node,
 671            Is_Greater_Key_Node => Is_Greater_Key_Node);
 672
 673       -------------
 674       -- Ceiling --
 675       -------------
 676
 677       function Ceiling (Container : Set; Key : Key_Type) return Cursor is
 678          Node : constant Node_Access :=
 679                   Key_Keys.Ceiling (Container.Tree, Key);
 680
 681       begin
 682          if Node = null then
 683             return No_Element;
 684          end if;
 685
 686          return Cursor'(Container'Unrestricted_Access, Node);
 687       end Ceiling;
 688
 689       --------------
 690       -- Contains --
 691       --------------
 692
 693       function Contains (Container : Set; Key : Key_Type) return Boolean is
 694       begin
 695          return Find (Container, Key) /= No_Element;
 696       end Contains;
 697
 698       ------------
 699       -- Delete --
 700       ------------
 701
 702       procedure Delete (Container : in out Set; Key : Key_Type) is
 703          Tree : Tree_Type renames Container.Tree;
 704          Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
 705          Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
 706          X    : Node_Access;
 707
 708       begin
 709          if Node = Done then
 710             raise Constraint_Error with "attempt to delete key not in set";
 711          end if;
 712
 713          loop
 714             X := Node;
 715             Node := Tree_Operations.Next (Node);
 716             Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 717             Free (X);
 718
 719             exit when Node = Done;
 720          end loop;
 721       end Delete;
 722
 723       -------------
 724       -- Element --
 725       -------------
 726
 727       function Element (Container : Set; Key : Key_Type) return Element_Type is
 728          Node : constant Node_Access :=
 729                   Key_Keys.Find (Container.Tree, Key);
 730
 731       begin
 732          if Node = null then
 733             raise Constraint_Error with "key not in set";
 734          end if;
 735
 736          return Node.Element.all;
 737       end Element;
 738
 739       ---------------------
 740       -- Equivalent_Keys --
 741       ---------------------
 742
 743       function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
 744       begin
 745          if Left < Right
 746            or else Right < Left
 747          then
 748             return False;
 749          else
 750             return True;
 751          end if;
 752       end Equivalent_Keys;
 753
 754       -------------
 755       -- Exclude --
 756       -------------
 757
 758       procedure Exclude (Container : in out Set; Key : Key_Type) is
 759          Tree : Tree_Type renames Container.Tree;
 760          Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
 761          Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
 762          X    : Node_Access;
 763
 764       begin
 765          while Node /= Done loop
 766             X := Node;
 767             Node := Tree_Operations.Next (Node);
 768             Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 769             Free (X);
 770          end loop;
 771       end Exclude;
 772
 773       ----------
 774       -- Find --
 775       ----------
 776
 777       function Find (Container : Set; Key : Key_Type) return Cursor is
 778          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 779
 780       begin
 781          if Node = null then
 782             return No_Element;
 783          end if;
 784
 785          return Cursor'(Container'Unrestricted_Access, Node);
 786       end Find;
 787
 788       -----------
 789       -- Floor --
 790       -----------
 791
 792       function Floor (Container : Set; Key : Key_Type) return Cursor is
 793          Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
 794
 795       begin
 796          if Node = null then
 797             return No_Element;
 798          end if;
 799
 800          return Cursor'(Container'Unrestricted_Access, Node);
 801       end Floor;
 802
 803       -------------------------
 804       -- Is_Greater_Key_Node --
 805       -------------------------
 806
 807       function Is_Greater_Key_Node
 808         (Left  : Key_Type;
 809          Right : Node_Access) return Boolean
 810       is
 811       begin
 812          return Key (Right.Element.all) < Left;
 813       end Is_Greater_Key_Node;
 814
 815       ----------------------
 816       -- Is_Less_Key_Node --
 817       ----------------------
 818
 819       function Is_Less_Key_Node
 820         (Left  : Key_Type;
 821          Right : Node_Access) return Boolean
 822       is
 823       begin
 824          return Left < Key (Right.Element.all);
 825       end Is_Less_Key_Node;
 826
 827       -------------
 828       -- Iterate --
 829       -------------
 830
 831       procedure Iterate
 832         (Container : Set;
 833          Key       : Key_Type;
 834          Process   : not null access procedure (Position : Cursor))
 835       is
 836          procedure Process_Node (Node : Node_Access);
 837          pragma Inline (Process_Node);
 838
 839          procedure Local_Iterate is
 840            new Key_Keys.Generic_Iteration (Process_Node);
 841
 842          ------------------
 843          -- Process_Node --
 844          ------------------
 845
 846          procedure Process_Node (Node : Node_Access) is
 847          begin
 848             Process (Cursor'(Container'Unrestricted_Access, Node));
 849          end Process_Node;
 850
 851          T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
 852          B : Natural renames T.Busy;
 853
 854       --  Start of processing for Iterate
 855
 856       begin
 857          B := B + 1;
 858
 859          begin
 860             Local_Iterate (T, Key);
 861          exception
 862             when others =>
 863                B := B - 1;
 864                raise;
 865          end;
 866
 867          B := B - 1;
 868       end Iterate;
 869
 870       ---------
 871       -- Key --
 872       ---------
 873
 874       function Key (Position : Cursor) return Key_Type is
 875       begin
 876          if Position.Node = null then
 877             raise Constraint_Error with
 878               "Position cursor equals No_Element";
 879          end if;
 880
 881          if Position.Node.Element = null then
 882             raise Program_Error with
 883               "Position cursor is bad";
 884          end if;
 885
 886          pragma Assert (Vet (Position.Container.Tree, Position.Node),
 887                         "bad cursor in Key");
 888
 889          return Key (Position.Node.Element.all);
 890       end Key;
 891
 892       ---------------------
 893       -- Reverse_Iterate --
 894       ---------------------
 895
 896       procedure Reverse_Iterate
 897         (Container : Set;
 898          Key       : Key_Type;
 899          Process   : not null access procedure (Position : Cursor))
 900       is
 901          procedure Process_Node (Node : Node_Access);
 902          pragma Inline (Process_Node);
 903
 904          -------------
 905          -- Iterate --
 906          -------------
 907
 908          procedure Local_Reverse_Iterate is
 909             new Key_Keys.Generic_Reverse_Iteration (Process_Node);
 910
 911          ------------------
 912          -- Process_Node --
 913          ------------------
 914
 915          procedure Process_Node (Node : Node_Access) is
 916          begin
 917             Process (Cursor'(Container'Unrestricted_Access, Node));
 918          end Process_Node;
 919
 920          T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
 921          B : Natural renames T.Busy;
 922
 923       --  Start of processing for Reverse_Iterate
 924
 925       begin
 926          B := B + 1;
 927
 928          begin
 929             Local_Reverse_Iterate (T, Key);
 930          exception
 931             when others =>
 932                B := B - 1;
 933                raise;
 934          end;
 935
 936          B := B - 1;
 937       end Reverse_Iterate;
 938
 939       --------------------
 940       -- Update_Element --
 941       --------------------
 942
 943       procedure Update_Element
 944         (Container : in out Set;
 945          Position  : Cursor;
 946          Process   : not null access procedure (Element : in out Element_Type))
 947       is
 948          Tree : Tree_Type renames Container.Tree;
 949          Node : constant Node_Access := Position.Node;
 950
 951       begin
 952          if Node = null then
 953             raise Constraint_Error with "Position cursor equals No_Element";
 954          end if;
 955
 956          if Node.Element = null then
 957             raise Program_Error with "Position cursor is bad";
 958          end if;
 959
 960          if Position.Container /= Container'Unrestricted_Access then
 961             raise Program_Error with "Position cursor designates wrong set";
 962          end if;
 963
 964          pragma Assert (Vet (Tree, Node),
 965                         "bad cursor in Update_Element");
 966
 967          declare
 968             E : Element_Type renames Node.Element.all;
 969             K : constant Key_Type := Key (E);
 970
 971             B : Natural renames Tree.Busy;
 972             L : Natural renames Tree.Lock;
 973
 974          begin
 975             B := B + 1;
 976             L := L + 1;
 977
 978             begin
 979                Process (E);
 980             exception
 981                when others =>
 982                   L := L - 1;
 983                   B := B - 1;
 984                   raise;
 985             end;
 986
 987             L := L - 1;
 988             B := B - 1;
 989
 990             if Equivalent_Keys (Left => K, Right => Key (E)) then
 991                return;
 992             end if;
 993          end;
 994
 995          --  Delete_Node checks busy-bit
 996
 997          Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
 998
 999          Insert_New_Item : declare
1000             function New_Node return Node_Access;
1001             pragma Inline (New_Node);
1002
1003             procedure Insert_Post is
1004                new Element_Keys.Generic_Insert_Post (New_Node);
1005
1006             procedure Unconditional_Insert is
1007                new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1008
1009             --------------
1010             -- New_Node --
1011             --------------
1012
1013             function New_Node return Node_Access is
1014             begin
1015                Node.Color := Red_Black_Trees.Red;
1016                Node.Parent := null;
1017                Node.Left := null;
1018                Node.Right := null;
1019
1020                return Node;
1021             end New_Node;
1022
1023             Result : Node_Access;
1024
1025          --  Start of processing for Insert_New_Item
1026
1027          begin
1028             Unconditional_Insert
1029               (Tree => Tree,
1030                Key  => Node.Element.all,
1031                Node => Result);
1032
1033             pragma Assert (Result = Node);
1034          end Insert_New_Item;
1035       end Update_Element;
1036
1037    end Generic_Keys;
1038
1039    -----------------
1040    -- Has_Element --
1041    -----------------
1042
1043    function Has_Element (Position : Cursor) return Boolean is
1044    begin
1045       return Position /= No_Element;
1046    end Has_Element;
1047
1048    ------------
1049    -- Insert --
1050    ------------
1051
1052    procedure Insert (Container : in out Set; New_Item : Element_Type) is
1053       Position : Cursor;
1054       pragma Unreferenced (Position);
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    : not null access Root_Stream_Type'Class;
1512       Container : out Set)
1513    is
1514       function Read_Node
1515         (Stream : not null 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 : not null 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 : not null 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       pragma Unreferenced (Node);
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    : not null access Root_Stream_Type'Class;
1827       Container : Set)
1828    is
1829       procedure Write_Node
1830         (Stream : not null 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 : not null 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 : not null 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;