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