gcc/ada/a-ciorse.adb

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