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