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