gcc/ada/a-coorse.adb

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