gcc/ada/a-ciormu.adb

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