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