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