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