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 with System; use type System.Address;
  43
  44 package body Ada.Containers.Bounded_Ordered_Sets is
  45
  46    type Iterator is new Limited_Controlled and
  47      Set_Iterator_Interfaces.Reversible_Iterator with
  48    record
  49       Container : Set_Access;
  50       Node      : Count_Type;
  51    end record;
  52
  53    overriding procedure Finalize (Object : in out Iterator);
  54
  55    overriding function First (Object : Iterator) return Cursor;
  56    overriding function Last  (Object : Iterator) return Cursor;
  57
  58    overriding function Next
  59      (Object   : Iterator;
  60       Position : Cursor) return Cursor;
  61
  62    overriding function Previous
  63      (Object   : Iterator;
  64       Position : Cursor) return Cursor;
  65
  66    ------------------------------
  67    -- Access to Fields of Node --
  68    ------------------------------
  69
  70    --  These subprograms provide functional notation for access to fields
  71    --  of a node, and procedural notation for modifying these fields.
  72
  73    function Color (Node : Node_Type) return Red_Black_Trees.Color_Type;
  74    pragma Inline (Color);
  75
  76    function Left (Node : Node_Type) return Count_Type;
  77    pragma Inline (Left);
  78
  79    function Parent (Node : Node_Type) return Count_Type;
  80    pragma Inline (Parent);
  81
  82    function Right (Node : Node_Type) return Count_Type;
  83    pragma Inline (Right);
  84
  85    procedure Set_Color
  86      (Node  : in out Node_Type;
  87       Color : Red_Black_Trees.Color_Type);
  88    pragma Inline (Set_Color);
  89
  90    procedure Set_Left (Node : in out Node_Type; Left : Count_Type);
  91    pragma Inline (Set_Left);
  92
  93    procedure Set_Right (Node : in out Node_Type; Right : Count_Type);
  94    pragma Inline (Set_Right);
  95
  96    procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type);
  97    pragma Inline (Set_Parent);
  98
  99    -----------------------
 100    -- Local Subprograms --
 101    -----------------------
 102
 103    procedure Insert_Sans_Hint
 104      (Container : in out Set;
 105       New_Item  : Element_Type;
 106       Node      : out Count_Type;
 107       Inserted  : out Boolean);
 108
 109    procedure Insert_With_Hint
 110      (Dst_Set  : in out Set;
 111       Dst_Hint : Count_Type;
 112       Src_Node : Node_Type;
 113       Dst_Node : out Count_Type);
 114
 115    function Is_Greater_Element_Node
 116      (Left  : Element_Type;
 117       Right : Node_Type) return Boolean;
 118    pragma Inline (Is_Greater_Element_Node);
 119
 120    function Is_Less_Element_Node
 121      (Left  : Element_Type;
 122       Right : Node_Type) return Boolean;
 123    pragma Inline (Is_Less_Element_Node);
 124
 125    function Is_Less_Node_Node (L, R : Node_Type) return Boolean;
 126    pragma Inline (Is_Less_Node_Node);
 127
 128    procedure Replace_Element
 129      (Container : in out Set;
 130       Index     : Count_Type;
 131       Item      : Element_Type);
 132
 133    --------------------------
 134    -- Local Instantiations --
 135    --------------------------
 136
 137    package Tree_Operations is
 138       new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types);
 139
 140    use Tree_Operations;
 141
 142    package Element_Keys is
 143       new Red_Black_Trees.Generic_Bounded_Keys
 144         (Tree_Operations     => Tree_Operations,
 145          Key_Type            => Element_Type,
 146          Is_Less_Key_Node    => Is_Less_Element_Node,
 147          Is_Greater_Key_Node => Is_Greater_Element_Node);
 148
 149    package Set_Ops is
 150       new Red_Black_Trees.Generic_Bounded_Set_Operations
 151         (Tree_Operations  => Tree_Operations,
 152          Set_Type         => Set,
 153          Assign           => Assign,
 154          Insert_With_Hint => Insert_With_Hint,
 155          Is_Less          => Is_Less_Node_Node);
 156
 157    ---------
 158    -- "<" --
 159    ---------
 160
 161    function "<" (Left, Right : Cursor) return Boolean is
 162    begin
 163       if Left.Node = 0 then
 164          raise Constraint_Error with "Left cursor equals No_Element";
 165       end if;
 166
 167       if Right.Node = 0 then
 168          raise Constraint_Error with "Right cursor equals No_Element";
 169       end if;
 170
 171       pragma Assert (Vet (Left.Container.all, Left.Node),
 172                      "bad Left cursor in ""<""");
 173
 174       pragma Assert (Vet (Right.Container.all, Right.Node),
 175                      "bad Right cursor in ""<""");
 176
 177       declare
 178          LN : Nodes_Type renames Left.Container.Nodes;
 179          RN : Nodes_Type renames Right.Container.Nodes;
 180       begin
 181          return LN (Left.Node).Element < RN (Right.Node).Element;
 182       end;
 183    end "<";
 184
 185    function "<" (Left : Cursor; Right : Element_Type) return Boolean is
 186    begin
 187       if Left.Node = 0 then
 188          raise Constraint_Error with "Left cursor equals No_Element";
 189       end if;
 190
 191       pragma Assert (Vet (Left.Container.all, Left.Node),
 192                      "bad Left cursor in ""<""");
 193
 194       return Left.Container.Nodes (Left.Node).Element < Right;
 195    end "<";
 196
 197    function "<" (Left : Element_Type; Right : Cursor) return Boolean is
 198    begin
 199       if Right.Node = 0 then
 200          raise Constraint_Error with "Right cursor equals No_Element";
 201       end if;
 202
 203       pragma Assert (Vet (Right.Container.all, Right.Node),
 204                      "bad Right cursor in ""<""");
 205
 206       return Left < Right.Container.Nodes (Right.Node).Element;
 207    end "<";
 208
 209    ---------
 210    -- "=" --
 211    ---------
 212
 213    function "=" (Left, Right : Set) return Boolean is
 214       function Is_Equal_Node_Node (L, R : Node_Type) return Boolean;
 215       pragma Inline (Is_Equal_Node_Node);
 216
 217       function Is_Equal is
 218          new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
 219
 220       ------------------------
 221       -- Is_Equal_Node_Node --
 222       ------------------------
 223
 224       function Is_Equal_Node_Node (L, R : Node_Type) return Boolean is
 225       begin
 226          return L.Element = R.Element;
 227       end Is_Equal_Node_Node;
 228
 229    --  Start of processing for Is_Equal
 230
 231    begin
 232       return Is_Equal (Left, Right);
 233    end "=";
 234
 235    ---------
 236    -- ">" --
 237    ---------
 238
 239    function ">" (Left, Right : Cursor) return Boolean is
 240    begin
 241       if Left.Node = 0 then
 242          raise Constraint_Error with "Left cursor equals No_Element";
 243       end if;
 244
 245       if Right.Node = 0 then
 246          raise Constraint_Error with "Right cursor equals No_Element";
 247       end if;
 248
 249       pragma Assert (Vet (Left.Container.all, Left.Node),
 250                      "bad Left cursor in "">""");
 251
 252       pragma Assert (Vet (Right.Container.all, Right.Node),
 253                      "bad Right cursor in "">""");
 254
 255       --  L > R same as R < L
 256
 257       declare
 258          LN : Nodes_Type renames Left.Container.Nodes;
 259          RN : Nodes_Type renames Right.Container.Nodes;
 260       begin
 261          return RN (Right.Node).Element < LN (Left.Node).Element;
 262       end;
 263    end ">";
 264
 265    function ">" (Left : Element_Type; Right : Cursor) return Boolean is
 266    begin
 267       if Right.Node = 0 then
 268          raise Constraint_Error with "Right cursor equals No_Element";
 269       end if;
 270
 271       pragma Assert (Vet (Right.Container.all, Right.Node),
 272                      "bad Right cursor in "">""");
 273
 274       return Right.Container.Nodes (Right.Node).Element < Left;
 275    end ">";
 276
 277    function ">" (Left : Cursor; Right : Element_Type) return Boolean is
 278    begin
 279       if Left.Node = 0 then
 280          raise Constraint_Error with "Left cursor equals No_Element";
 281       end if;
 282
 283       pragma Assert (Vet (Left.Container.all, Left.Node),
 284                      "bad Left cursor in "">""");
 285
 286       return Right < Left.Container.Nodes (Left.Node).Element;
 287    end ">";
 288
 289    ------------
 290    -- Assign --
 291    ------------
 292
 293    procedure Assign (Target : in out Set; Source : Set) is
 294       procedure Append_Element (Source_Node : Count_Type);
 295
 296       procedure Append_Elements is
 297          new Tree_Operations.Generic_Iteration (Append_Element);
 298
 299       --------------------
 300       -- Append_Element --
 301       --------------------
 302
 303       procedure Append_Element (Source_Node : Count_Type) is
 304          SN : Node_Type renames Source.Nodes (Source_Node);
 305
 306          procedure Set_Element (Node : in out Node_Type);
 307          pragma Inline (Set_Element);
 308
 309          function New_Node return Count_Type;
 310          pragma Inline (New_Node);
 311
 312          procedure Insert_Post is
 313             new Element_Keys.Generic_Insert_Post (New_Node);
 314
 315          procedure Unconditional_Insert_Sans_Hint is
 316             new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
 317
 318          procedure Unconditional_Insert_Avec_Hint is
 319             new Element_Keys.Generic_Unconditional_Insert_With_Hint
 320               (Insert_Post,
 321                Unconditional_Insert_Sans_Hint);
 322
 323          procedure Allocate is
 324             new Tree_Operations.Generic_Allocate (Set_Element);
 325
 326          --------------
 327          -- New_Node --
 328          --------------
 329
 330          function New_Node return Count_Type is
 331             Result : Count_Type;
 332          begin
 333             Allocate (Target, Result);
 334             return Result;
 335          end New_Node;
 336
 337          -----------------
 338          -- Set_Element --
 339          -----------------
 340
 341          procedure Set_Element (Node : in out Node_Type) is
 342          begin
 343             Node.Element := SN.Element;
 344          end Set_Element;
 345
 346          Target_Node : Count_Type;
 347
 348       --  Start of processing for Append_Element
 349
 350       begin
 351          Unconditional_Insert_Avec_Hint
 352            (Tree  => Target,
 353             Hint  => 0,
 354             Key   => SN.Element,
 355             Node  => Target_Node);
 356       end Append_Element;
 357
 358    --  Start of processing for Assign
 359
 360    begin
 361       if Target'Address = Source'Address then
 362          return;
 363       end if;
 364
 365       if Target.Capacity < Source.Length then
 366          raise Capacity_Error
 367            with "Target capacity is less than Source length";
 368       end if;
 369
 370       Target.Clear;
 371       Append_Elements (Source);
 372    end Assign;
 373
 374    -------------
 375    -- Ceiling --
 376    -------------
 377
 378    function Ceiling (Container : Set; Item : Element_Type) return Cursor is
 379       Node : constant Count_Type :=
 380                Element_Keys.Ceiling (Container, Item);
 381    begin
 382       return (if Node = 0 then No_Element
 383               else Cursor'(Container'Unrestricted_Access, Node));
 384    end Ceiling;
 385
 386    -----------
 387    -- Clear --
 388    -----------
 389
 390    procedure Clear (Container : in out Set) is
 391    begin
 392       Tree_Operations.Clear_Tree (Container);
 393    end Clear;
 394
 395    -----------
 396    -- Color --
 397    -----------
 398
 399    function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is
 400    begin
 401       return Node.Color;
 402    end Color;
 403
 404    --------------
 405    -- Contains --
 406    --------------
 407
 408    function Contains
 409      (Container : Set;
 410       Item      : Element_Type) return Boolean
 411    is
 412    begin
 413       return Find (Container, Item) /= No_Element;
 414    end Contains;
 415
 416    ----------
 417    -- Copy --
 418    ----------
 419
 420    function Copy (Source : Set; Capacity : Count_Type := 0) return Set is
 421       C : Count_Type;
 422
 423    begin
 424       if Capacity = 0 then
 425          C := Source.Length;
 426       elsif Capacity >= Source.Length then
 427          C := Capacity;
 428       else
 429          raise Capacity_Error with "Capacity value too small";
 430       end if;
 431
 432       return Target : Set (Capacity => C) do
 433          Assign (Target => Target, Source => Source);
 434       end return;
 435    end Copy;
 436
 437    ------------
 438    -- Delete --
 439    ------------
 440
 441    procedure Delete (Container : in out Set; Position : in out Cursor) is
 442    begin
 443       if Position.Node = 0 then
 444          raise Constraint_Error with "Position cursor equals No_Element";
 445       end if;
 446
 447       if Position.Container /= Container'Unrestricted_Access then
 448          raise Program_Error with "Position cursor designates wrong set";
 449       end if;
 450
 451       pragma Assert (Vet (Container, Position.Node),
 452                      "bad cursor in Delete");
 453
 454       Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node);
 455       Tree_Operations.Free (Container, Position.Node);
 456
 457       Position := No_Element;
 458    end Delete;
 459
 460    procedure Delete (Container : in out Set; Item : Element_Type) is
 461       X : constant Count_Type := Element_Keys.Find (Container, Item);
 462
 463    begin
 464       if X = 0 then
 465          raise Constraint_Error with "attempt to delete element not in set";
 466       end if;
 467
 468       Tree_Operations.Delete_Node_Sans_Free (Container, X);
 469       Tree_Operations.Free (Container, X);
 470    end Delete;
 471
 472    ------------------
 473    -- Delete_First --
 474    ------------------
 475
 476    procedure Delete_First (Container : in out Set) is
 477       X : constant Count_Type := Container.First;
 478    begin
 479       if X /= 0 then
 480          Tree_Operations.Delete_Node_Sans_Free (Container, X);
 481          Tree_Operations.Free (Container, X);
 482       end if;
 483    end Delete_First;
 484
 485    -----------------
 486    -- Delete_Last --
 487    -----------------
 488
 489    procedure Delete_Last (Container : in out Set) is
 490       X : constant Count_Type := Container.Last;
 491    begin
 492       if X /= 0 then
 493          Tree_Operations.Delete_Node_Sans_Free (Container, X);
 494          Tree_Operations.Free (Container, X);
 495       end if;
 496    end Delete_Last;
 497
 498    ----------------
 499    -- Difference --
 500    ----------------
 501
 502    procedure Difference (Target : in out Set; Source : Set)
 503       renames Set_Ops.Set_Difference;
 504
 505    function Difference (Left, Right : Set) return Set
 506       renames Set_Ops.Set_Difference;
 507
 508    -------------
 509    -- Element --
 510    -------------
 511
 512    function Element (Position : Cursor) return Element_Type is
 513    begin
 514       if Position.Node = 0 then
 515          raise Constraint_Error with "Position cursor equals No_Element";
 516       end if;
 517
 518       pragma Assert (Vet (Position.Container.all, Position.Node),
 519                      "bad cursor in Element");
 520
 521       return Position.Container.Nodes (Position.Node).Element;
 522    end Element;
 523
 524    -------------------------
 525    -- Equivalent_Elements --
 526    -------------------------
 527
 528    function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
 529    begin
 530       return (if Left < Right or else Right < Left then False else True);
 531    end Equivalent_Elements;
 532
 533    ---------------------
 534    -- Equivalent_Sets --
 535    ---------------------
 536
 537    function Equivalent_Sets (Left, Right : Set) return Boolean is
 538       function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean;
 539       pragma Inline (Is_Equivalent_Node_Node);
 540
 541       function Is_Equivalent is
 542          new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
 543
 544       -----------------------------
 545       -- Is_Equivalent_Node_Node --
 546       -----------------------------
 547
 548       function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is
 549       begin
 550          return (if L.Element < R.Element then False
 551                  elsif R.Element < L.Element then False
 552                  else True);
 553       end Is_Equivalent_Node_Node;
 554
 555    --  Start of processing for Equivalent_Sets
 556
 557    begin
 558       return Is_Equivalent (Left, Right);
 559    end Equivalent_Sets;
 560
 561    -------------
 562    -- Exclude --
 563    -------------
 564
 565    procedure Exclude (Container : in out Set; Item : Element_Type) is
 566       X : constant Count_Type := Element_Keys.Find (Container, Item);
 567    begin
 568       if X /= 0 then
 569          Tree_Operations.Delete_Node_Sans_Free (Container, X);
 570          Tree_Operations.Free (Container, X);
 571       end if;
 572    end Exclude;
 573
 574    --------------
 575    -- Finalize --
 576    --------------
 577
 578    procedure Finalize (Object : in out Iterator) is
 579    begin
 580       if Object.Container /= null then
 581          declare
 582             B : Natural renames Object.Container.all.Busy;
 583
 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;