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