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