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