gcc/ada/a-coormu.adb

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