gcc/ada/a-ciorse.adb

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