gcc/ada/a-coormu.adb

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