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