gcc/ada/a-cborse.adb

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