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