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-2005, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- This specification is derived from the Ada Reference Manual for use with --
  12 -- GNAT. The copyright notice above, and the license provisions that follow --
  13 -- apply solely to the  contents of the part following the private keyword. --
  14 --                                                                          --
  15 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  16 -- terms of the  GNU General Public License as published  by the Free Soft- --
  17 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  18 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  19 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  20 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  21 -- for  more details.  You should have  received  a copy of the GNU General --
  22 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  23 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  24 -- Boston, MA 02110-1301, USA.                                              --
  25 --                                                                          --
  26 -- As a special exception,  if other files  instantiate  generics from this --
  27 -- unit, or you link  this unit with other files  to produce an executable, --
  28 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  29 -- covered  by the  GNU  General  Public  License.  This exception does not --
  30 -- however invalidate  any other reasons why  the executable file  might be --
  31 -- covered by the  GNU Public License.                                      --
  32 --                                                                          --
  33 -- This unit was originally developed by Matthew J Heaney.                  --
  34 ------------------------------------------------------------------------------
  35
  36 with Ada.Unchecked_Deallocation;
  37
  38 with Ada.Containers.Red_Black_Trees.Generic_Operations;
  39 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
  40
  41 with Ada.Containers.Red_Black_Trees.Generic_Keys;
  42 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
  43
  44 with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
  45 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
  46
  47 package body Ada.Containers.Ordered_Sets is
  48
  49    ------------------------------
  50    -- Access to Fields of Node --
  51    ------------------------------
  52
  53    --  These subprograms provide functional notation for access to fields
  54    --  of a node, and procedural notation for modifiying these fields.
  55
  56    function Color (Node : Node_Access) return Color_Type;
  57    pragma Inline (Color);
  58
  59    function Left (Node : Node_Access) return Node_Access;
  60    pragma Inline (Left);
  61
  62    function Parent (Node : Node_Access) return Node_Access;
  63    pragma Inline (Parent);
  64
  65    function Right (Node : Node_Access) return Node_Access;
  66    pragma Inline (Right);
  67
  68    procedure Set_Color (Node : Node_Access; Color : Color_Type);
  69    pragma Inline (Set_Color);
  70
  71    procedure Set_Left (Node : Node_Access; Left : Node_Access);
  72    pragma Inline (Set_Left);
  73
  74    procedure Set_Right (Node : Node_Access; Right : Node_Access);
  75    pragma Inline (Set_Right);
  76
  77    procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
  78    pragma Inline (Set_Parent);
  79
  80    -----------------------
  81    -- Local Subprograms --
  82    -----------------------
  83
  84    function Copy_Node (Source : Node_Access) return Node_Access;
  85    pragma Inline (Copy_Node);
  86
  87    procedure Free (X : in out Node_Access);
  88
  89    procedure Insert_Sans_Hint
  90      (Tree     : in out Tree_Type;
  91       New_Item : Element_Type;
  92       Node     : out Node_Access;
  93       Inserted : out Boolean);
  94
  95    procedure Insert_With_Hint
  96      (Dst_Tree : in out Tree_Type;
  97       Dst_Hint : Node_Access;
  98       Src_Node : Node_Access;
  99       Dst_Node : out Node_Access);
 100
 101    function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
 102    pragma Inline (Is_Equal_Node_Node);
 103
 104    function Is_Greater_Element_Node
 105      (Left  : Element_Type;
 106       Right : Node_Access) return Boolean;
 107    pragma Inline (Is_Greater_Element_Node);
 108
 109    function Is_Less_Element_Node
 110      (Left  : Element_Type;
 111       Right : Node_Access) return Boolean;
 112    pragma Inline (Is_Less_Element_Node);
 113
 114    function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
 115    pragma Inline (Is_Less_Node_Node);
 116
 117    procedure Replace_Element
 118      (Tree : in out Tree_Type;
 119       Node : Node_Access;
 120       Item : Element_Type);
 121
 122    --------------------------
 123    -- Local Instantiations --
 124    --------------------------
 125
 126    package Tree_Operations is
 127      new Red_Black_Trees.Generic_Operations (Tree_Types);
 128
 129    procedure Delete_Tree is
 130       new Tree_Operations.Generic_Delete_Tree (Free);
 131
 132    function Copy_Tree is
 133       new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
 134
 135    use Tree_Operations;
 136
 137    function Is_Equal is
 138      new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
 139
 140    package Element_Keys is
 141      new Red_Black_Trees.Generic_Keys
 142       (Tree_Operations     => Tree_Operations,
 143        Key_Type            => Element_Type,
 144        Is_Less_Key_Node    => Is_Less_Element_Node,
 145        Is_Greater_Key_Node => Is_Greater_Element_Node);
 146
 147    package Set_Ops is
 148      new Generic_Set_Operations
 149       (Tree_Operations  => Tree_Operations,
 150        Insert_With_Hint => Insert_With_Hint,
 151        Copy_Tree        => Copy_Tree,
 152        Delete_Tree      => Delete_Tree,
 153        Is_Less          => Is_Less_Node_Node,
 154        Free             => Free);
 155
 156    ---------
 157    -- "<" --
 158    ---------
 159
 160    function "<" (Left, Right : Cursor) return Boolean is
 161    begin
 162       if Left.Node = null
 163         or else Right.Node = null
 164       then
 165          raise Constraint_Error;
 166       end if;
 167
 168       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 169                      "bad Left cursor in ""<""");
 170
 171       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 172                      "bad Right cursor in ""<""");
 173
 174       return Left.Node.Element < Right.Node.Element;
 175    end "<";
 176
 177    function "<" (Left : Cursor; Right : Element_Type) return Boolean is
 178    begin
 179       if Left.Node = null then
 180          raise Constraint_Error;
 181       end if;
 182
 183       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 184                      "bad Left cursor in ""<""");
 185
 186       return Left.Node.Element < Right;
 187    end "<";
 188
 189    function "<" (Left : Element_Type; Right : Cursor) return Boolean is
 190    begin
 191       if Right.Node = null then
 192          raise Constraint_Error;
 193       end if;
 194
 195       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 196                      "bad Right cursor in ""<""");
 197
 198       return Left < Right.Node.Element;
 199    end "<";
 200
 201    ---------
 202    -- "=" --
 203    ---------
 204
 205    function "=" (Left, Right : Set) return Boolean is
 206    begin
 207       return Is_Equal (Left.Tree, Right.Tree);
 208    end "=";
 209
 210    ---------
 211    -- ">" --
 212    ---------
 213
 214    function ">" (Left, Right : Cursor) return Boolean is
 215    begin
 216       if Left.Node = null
 217         or else Right.Node = null
 218       then
 219          raise Constraint_Error;
 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;
 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;
 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;
 341       end if;
 342
 343       if Position.Container /= Container'Unrestricted_Access then
 344          raise Program_Error;
 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;
 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;
 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;
 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;
 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;
 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;
 745          end if;
 746
 747          pragma Assert (Vet (Position.Container.Tree, Position.Node),
 748                         "bad cursor in Key");
 749
 750          return Key (Position.Node.Element);
 751       end Key;
 752
 753       -------------
 754       -- Replace --
 755       -------------
 756
 757       procedure Replace
 758         (Container : in out Set;
 759          Key       : Key_Type;
 760          New_Item  : Element_Type)
 761       is
 762          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 763
 764       begin
 765          if Node = null then
 766             raise Constraint_Error;
 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;
 786          end if;
 787
 788          if Position.Container /= Container'Unrestricted_Access then
 789             raise Program_Error;
 790          end if;
 791
 792          pragma Assert (Vet (Container.Tree, Position.Node),
 793                         "bad cursor in Update_Element_Preserving_Key");
 794
 795          declare
 796             E : Element_Type renames Position.Node.Element;
 797             K : constant Key_Type := Key (E);
 798
 799             B : Natural renames Tree.Busy;
 800             L : Natural renames Tree.Lock;
 801
 802          begin
 803             B := B + 1;
 804             L := L + 1;
 805
 806             begin
 807                Process (E);
 808             exception
 809                when others =>
 810                   L := L - 1;
 811                   B := B - 1;
 812                   raise;
 813             end;
 814
 815             L := L - 1;
 816             B := B - 1;
 817
 818             if Equivalent_Keys (K, Key (E)) then
 819                return;
 820             end if;
 821          end;
 822
 823          declare
 824             X : Node_Access := Position.Node;
 825          begin
 826             Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 827             Free (X);
 828          end;
 829
 830          raise Program_Error;
 831       end Update_Element_Preserving_Key;
 832
 833    end Generic_Keys;
 834
 835    -----------------
 836    -- Has_Element --
 837    -----------------
 838
 839    function Has_Element (Position : Cursor) return Boolean is
 840    begin
 841       return Position /= No_Element;
 842    end Has_Element;
 843
 844    -------------
 845    -- Include --
 846    -------------
 847
 848    procedure Include (Container : in out Set; New_Item : Element_Type) is
 849       Position : Cursor;
 850       Inserted : Boolean;
 851
 852    begin
 853       Insert (Container, New_Item, Position, Inserted);
 854
 855       if not Inserted then
 856          if Container.Tree.Lock > 0 then
 857             raise Program_Error;
 858          end if;
 859
 860          Position.Node.Element := New_Item;
 861       end if;
 862    end Include;
 863
 864    ------------
 865    -- Insert --
 866    ------------
 867
 868    procedure Insert
 869      (Container : in out Set;
 870       New_Item  : Element_Type;
 871       Position  : out Cursor;
 872       Inserted  : out Boolean)
 873    is
 874    begin
 875       Insert_Sans_Hint
 876         (Container.Tree,
 877          New_Item,
 878          Position.Node,
 879          Inserted);
 880
 881       Position.Container := Container'Unrestricted_Access;
 882    end Insert;
 883
 884    procedure Insert
 885      (Container : in out Set;
 886       New_Item  : Element_Type)
 887    is
 888       Position : Cursor;
 889       Inserted : Boolean;
 890
 891    begin
 892       Insert (Container, New_Item, Position, Inserted);
 893
 894       if not Inserted then
 895          raise Constraint_Error;
 896       end if;
 897    end Insert;
 898
 899    ----------------------
 900    -- Insert_Sans_Hint --
 901    ----------------------
 902
 903    procedure Insert_Sans_Hint
 904      (Tree     : in out Tree_Type;
 905       New_Item : Element_Type;
 906       Node     : out Node_Access;
 907       Inserted : out Boolean)
 908    is
 909       function New_Node return Node_Access;
 910       pragma Inline (New_Node);
 911
 912       procedure Insert_Post is
 913         new Element_Keys.Generic_Insert_Post (New_Node);
 914
 915       procedure Conditional_Insert_Sans_Hint is
 916         new Element_Keys.Generic_Conditional_Insert (Insert_Post);
 917
 918       --------------
 919       -- New_Node --
 920       --------------
 921
 922       function New_Node return Node_Access is
 923       begin
 924          return new Node_Type'(Parent  => null,
 925                                Left    => null,
 926                                Right   => null,
 927                                Color   => Red_Black_Trees.Red,
 928                                Element => New_Item);
 929       end New_Node;
 930
 931    --  Start of processing for Insert_Sans_Hint
 932
 933    begin
 934       Conditional_Insert_Sans_Hint
 935         (Tree,
 936          New_Item,
 937          Node,
 938          Inserted);
 939    end Insert_Sans_Hint;
 940
 941    ----------------------
 942    -- Insert_With_Hint --
 943    ----------------------
 944
 945    procedure Insert_With_Hint
 946      (Dst_Tree : in out Tree_Type;
 947       Dst_Hint : Node_Access;
 948       Src_Node : Node_Access;
 949       Dst_Node : out Node_Access)
 950    is
 951       Success : Boolean;
 952
 953       function New_Node return Node_Access;
 954       pragma Inline (New_Node);
 955
 956       procedure Insert_Post is
 957         new Element_Keys.Generic_Insert_Post (New_Node);
 958
 959       procedure Insert_Sans_Hint is
 960         new Element_Keys.Generic_Conditional_Insert (Insert_Post);
 961
 962       procedure Local_Insert_With_Hint is
 963         new Element_Keys.Generic_Conditional_Insert_With_Hint
 964           (Insert_Post,
 965            Insert_Sans_Hint);
 966
 967       --------------
 968       -- New_Node --
 969       --------------
 970
 971       function New_Node return Node_Access is
 972          Node : constant Node_Access :=
 973            new Node_Type'(Parent  => null,
 974                           Left    => null,
 975                           Right   => null,
 976                           Color   => Red,
 977                           Element => Src_Node.Element);
 978       begin
 979          return Node;
 980       end New_Node;
 981
 982    --  Start of processing for Insert_With_Hint
 983
 984    begin
 985       Local_Insert_With_Hint
 986         (Dst_Tree,
 987          Dst_Hint,
 988          Src_Node.Element,
 989          Dst_Node,
 990          Success);
 991    end Insert_With_Hint;
 992
 993    ------------------
 994    -- Intersection --
 995    ------------------
 996
 997    procedure Intersection (Target : in out Set; Source : Set) is
 998    begin
 999       Set_Ops.Intersection (Target.Tree, Source.Tree);
1000    end Intersection;
1001
1002    function Intersection (Left, Right : Set) return Set is
1003       Tree : constant Tree_Type :=
1004                Set_Ops.Intersection (Left.Tree, Right.Tree);
1005    begin
1006       return Set'(Controlled with Tree);
1007    end Intersection;
1008
1009    --------------
1010    -- Is_Empty --
1011    --------------
1012
1013    function Is_Empty (Container : Set) return Boolean is
1014    begin
1015       return Container.Tree.Length = 0;
1016    end Is_Empty;
1017
1018    ------------------------
1019    -- Is_Equal_Node_Node --
1020    ------------------------
1021
1022    function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1023    begin
1024       return L.Element = R.Element;
1025    end Is_Equal_Node_Node;
1026
1027    -----------------------------
1028    -- Is_Greater_Element_Node --
1029    -----------------------------
1030
1031    function Is_Greater_Element_Node
1032      (Left  : Element_Type;
1033       Right : Node_Access) return Boolean
1034    is
1035    begin
1036       --  Compute e > node same as node < e
1037
1038       return Right.Element < Left;
1039    end Is_Greater_Element_Node;
1040
1041    --------------------------
1042    -- Is_Less_Element_Node --
1043    --------------------------
1044
1045    function Is_Less_Element_Node
1046      (Left  : Element_Type;
1047       Right : Node_Access) return Boolean
1048    is
1049    begin
1050       return Left < Right.Element;
1051    end Is_Less_Element_Node;
1052
1053    -----------------------
1054    -- Is_Less_Node_Node --
1055    -----------------------
1056
1057    function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1058    begin
1059       return L.Element < R.Element;
1060    end Is_Less_Node_Node;
1061
1062    ---------------
1063    -- Is_Subset --
1064    ---------------
1065
1066    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1067    begin
1068       return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1069    end Is_Subset;
1070
1071    -------------
1072    -- Iterate --
1073    -------------
1074
1075    procedure Iterate
1076      (Container : Set;
1077       Process   : not null access procedure (Position : Cursor))
1078    is
1079       procedure Process_Node (Node : Node_Access);
1080       pragma Inline (Process_Node);
1081
1082       procedure Local_Iterate is
1083         new Tree_Operations.Generic_Iteration (Process_Node);
1084
1085       ------------------
1086       -- Process_Node --
1087       ------------------
1088
1089       procedure Process_Node (Node : Node_Access) is
1090       begin
1091          Process (Cursor'(Container'Unrestricted_Access, Node));
1092       end Process_Node;
1093
1094       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1095       B : Natural renames T.Busy;
1096
1097    --  Start of prccessing for Iterate
1098
1099    begin
1100       B := B + 1;
1101
1102       begin
1103          Local_Iterate (T);
1104       exception
1105          when others =>
1106             B := B - 1;
1107             raise;
1108       end;
1109
1110       B := B - 1;
1111    end Iterate;
1112
1113    ----------
1114    -- Last --
1115    ----------
1116
1117    function Last (Container : Set) return Cursor is
1118    begin
1119       if Container.Tree.Last = null then
1120          return No_Element;
1121       end if;
1122
1123       return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
1124    end Last;
1125
1126    ------------------
1127    -- Last_Element --
1128    ------------------
1129
1130    function Last_Element (Container : Set) return Element_Type is
1131    begin
1132       if Container.Tree.Last = null then
1133          raise Constraint_Error;
1134       end if;
1135
1136       return Container.Tree.Last.Element;
1137    end Last_Element;
1138
1139    ----------
1140    -- Left --
1141    ----------
1142
1143    function Left (Node : Node_Access) return Node_Access is
1144    begin
1145       return Node.Left;
1146    end Left;
1147
1148    ------------
1149    -- Length --
1150    ------------
1151
1152    function Length (Container : Set) return Count_Type is
1153    begin
1154       return Container.Tree.Length;
1155    end Length;
1156
1157    ----------
1158    -- Move --
1159    ----------
1160
1161    procedure Move is
1162       new Tree_Operations.Generic_Move (Clear);
1163
1164    procedure Move (Target : in out Set; Source : in out Set) is
1165    begin
1166       Move (Target => Target.Tree, Source => Source.Tree);
1167    end Move;
1168
1169    ----------
1170    -- Next --
1171    ----------
1172
1173    function Next (Position : Cursor) return Cursor is
1174    begin
1175       if Position = No_Element then
1176          return No_Element;
1177       end if;
1178
1179       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1180                      "bad cursor in Next");
1181
1182       declare
1183          Node : constant Node_Access :=
1184                   Tree_Operations.Next (Position.Node);
1185
1186       begin
1187          if Node = null then
1188             return No_Element;
1189          end if;
1190
1191          return Cursor'(Position.Container, Node);
1192       end;
1193    end Next;
1194
1195    procedure Next (Position : in out Cursor) is
1196    begin
1197       Position := Next (Position);
1198    end Next;
1199
1200    -------------
1201    -- Overlap --
1202    -------------
1203
1204    function Overlap (Left, Right : Set) return Boolean is
1205    begin
1206       return Set_Ops.Overlap (Left.Tree, Right.Tree);
1207    end Overlap;
1208
1209    ------------
1210    -- Parent --
1211    ------------
1212
1213    function Parent (Node : Node_Access) return Node_Access is
1214    begin
1215       return Node.Parent;
1216    end Parent;
1217
1218    --------------
1219    -- Previous --
1220    --------------
1221
1222    function Previous (Position : Cursor) return Cursor is
1223    begin
1224       if Position = No_Element then
1225          return No_Element;
1226       end if;
1227
1228       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1229                      "bad cursor in Previous");
1230
1231       declare
1232          Node : constant Node_Access :=
1233                   Tree_Operations.Previous (Position.Node);
1234
1235       begin
1236          if Node = null then
1237             return No_Element;
1238          end if;
1239
1240          return Cursor'(Position.Container, Node);
1241       end;
1242    end Previous;
1243
1244    procedure Previous (Position : in out Cursor) is
1245    begin
1246       Position := Previous (Position);
1247    end Previous;
1248
1249    -------------------
1250    -- Query_Element --
1251    -------------------
1252
1253    procedure Query_Element
1254      (Position : Cursor;
1255       Process  : not null access procedure (Element : Element_Type))
1256    is
1257    begin
1258       if Position.Node = null then
1259          raise Constraint_Error;
1260       end if;
1261
1262       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1263                      "bad cursor in Query_Element");
1264
1265       declare
1266          T : Tree_Type renames Position.Container.Tree;
1267
1268          B : Natural renames T.Busy;
1269          L : Natural renames T.Lock;
1270
1271       begin
1272          B := B + 1;
1273          L := L + 1;
1274
1275          begin
1276             Process (Position.Node.Element);
1277          exception
1278             when others =>
1279                L := L - 1;
1280                B := B - 1;
1281                raise;
1282          end;
1283
1284          L := L - 1;
1285          B := B - 1;
1286       end;
1287    end Query_Element;
1288
1289    ----------
1290    -- Read --
1291    ----------
1292
1293    procedure Read
1294      (Stream    : access Root_Stream_Type'Class;
1295       Container : out Set)
1296    is
1297       function Read_Node
1298         (Stream : access Root_Stream_Type'Class) return Node_Access;
1299       pragma Inline (Read_Node);
1300
1301       procedure Read is
1302          new Tree_Operations.Generic_Read (Clear, Read_Node);
1303
1304       ---------------
1305       -- Read_Node --
1306       ---------------
1307
1308       function Read_Node
1309         (Stream : access Root_Stream_Type'Class) return Node_Access
1310       is
1311          Node : Node_Access := new Node_Type;
1312
1313       begin
1314          Element_Type'Read (Stream, Node.Element);
1315          return Node;
1316
1317       exception
1318          when others =>
1319             Free (Node);
1320             raise;
1321       end Read_Node;
1322
1323    --  Start of processing for Read
1324
1325    begin
1326       Read (Stream, Container.Tree);
1327    end Read;
1328
1329    procedure Read
1330      (Stream : access Root_Stream_Type'Class;
1331       Item   : out Cursor)
1332    is
1333    begin
1334       raise Program_Error;
1335    end Read;
1336
1337    -------------
1338    -- Replace --
1339    -------------
1340
1341    procedure Replace (Container : in out Set; New_Item : Element_Type) is
1342       Node : constant Node_Access :=
1343                Element_Keys.Find (Container.Tree, New_Item);
1344
1345    begin
1346       if Node = null then
1347          raise Constraint_Error;
1348       end if;
1349
1350       if Container.Tree.Lock > 0 then
1351          raise Program_Error;
1352       end if;
1353
1354       Node.Element := New_Item;
1355    end Replace;
1356
1357    ---------------------
1358    -- Replace_Element --
1359    ---------------------
1360
1361    procedure Replace_Element
1362      (Tree : in out Tree_Type;
1363       Node : Node_Access;
1364       Item : Element_Type)
1365    is
1366    begin
1367       if Item < Node.Element
1368         or else Node.Element < Item
1369       then
1370          null;
1371       else
1372          if Tree.Lock > 0 then
1373             raise Program_Error;
1374          end if;
1375
1376          Node.Element := Item;
1377          return;
1378       end if;
1379
1380       Tree_Operations.Delete_Node_Sans_Free (Tree, Node);  -- Checks busy-bit
1381
1382       Insert_New_Item : declare
1383          function New_Node return Node_Access;
1384          pragma Inline (New_Node);
1385
1386          procedure Insert_Post is
1387             new Element_Keys.Generic_Insert_Post (New_Node);
1388
1389          procedure Insert is
1390             new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1391
1392          --------------
1393          -- New_Node --
1394          --------------
1395
1396          function New_Node return Node_Access is
1397          begin
1398             Node.Element := Item;
1399             Node.Color := Red;
1400             Node.Parent := null;
1401             Node.Right := null;
1402             Node.Left := null;
1403
1404             return Node;
1405          end New_Node;
1406
1407          Result   : Node_Access;
1408          Inserted : Boolean;
1409
1410       --  Start of processing for Insert_New_Item
1411
1412       begin
1413          Insert
1414            (Tree    => Tree,
1415             Key     => Item,
1416             Node    => Result,
1417             Success => Inserted);  --  TODO: change param name
1418
1419          if Inserted then
1420             pragma Assert (Result = Node);
1421             return;
1422          end if;
1423       exception
1424          when others =>
1425             null;  -- Assignment must have failed
1426       end Insert_New_Item;
1427
1428       Reinsert_Old_Element : declare
1429          function New_Node return Node_Access;
1430          pragma Inline (New_Node);
1431
1432          procedure Insert_Post is
1433             new Element_Keys.Generic_Insert_Post (New_Node);
1434
1435          procedure Insert is
1436             new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1437
1438          --------------
1439          -- New_Node --
1440          --------------
1441
1442          function New_Node return Node_Access is
1443          begin
1444             Node.Color := Red;
1445             Node.Parent := null;
1446             Node.Right := null;
1447             Node.Left := null;
1448
1449             return Node;
1450          end New_Node;
1451
1452          Result   : Node_Access;
1453          Inserted : Boolean;
1454
1455       --  Start of processing for Reinsert_Old_Element
1456
1457       begin
1458          Insert
1459            (Tree    => Tree,
1460             Key     => Node.Element,
1461             Node    => Result,
1462             Success => Inserted);  --  TODO: change param name
1463       exception
1464          when others =>
1465             null;  -- Assignment must have failed
1466       end Reinsert_Old_Element;
1467
1468       raise Program_Error;
1469    end Replace_Element;
1470
1471    procedure Replace_Element
1472      (Container : in out Set;
1473       Position  : Cursor;
1474       New_Item  : Element_Type)
1475    is
1476    begin
1477       if Position.Node = null then
1478          raise Constraint_Error;
1479       end if;
1480
1481       if Position.Container /= Container'Unrestricted_Access then
1482          raise Program_Error;
1483       end if;
1484
1485       pragma Assert (Vet (Container.Tree, Position.Node),
1486                      "bad cursor in Replace_Element");
1487
1488       Replace_Element (Container.Tree, Position.Node, New_Item);
1489    end Replace_Element;
1490
1491    ---------------------
1492    -- Reverse_Iterate --
1493    ---------------------
1494
1495    procedure Reverse_Iterate
1496      (Container : Set;
1497       Process   : not null access procedure (Position : Cursor))
1498    is
1499       procedure Process_Node (Node : Node_Access);
1500       pragma Inline (Process_Node);
1501
1502       procedure Local_Reverse_Iterate is
1503          new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1504
1505       ------------------
1506       -- Process_Node --
1507       ------------------
1508
1509       procedure Process_Node (Node : Node_Access) is
1510       begin
1511          Process (Cursor'(Container'Unrestricted_Access, Node));
1512       end Process_Node;
1513
1514       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1515       B : Natural renames T.Busy;
1516
1517    --  Start of processing for Reverse_Iterate
1518
1519    begin
1520       B := B + 1;
1521
1522       begin
1523          Local_Reverse_Iterate (T);
1524       exception
1525          when others =>
1526             B := B - 1;
1527             raise;
1528       end;
1529
1530       B := B - 1;
1531    end Reverse_Iterate;
1532
1533    -----------
1534    -- Right --
1535    -----------
1536
1537    function Right (Node : Node_Access) return Node_Access is
1538    begin
1539       return Node.Right;
1540    end Right;
1541
1542    ---------------
1543    -- Set_Color --
1544    ---------------
1545
1546    procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1547    begin
1548       Node.Color := Color;
1549    end Set_Color;
1550
1551    --------------
1552    -- Set_Left --
1553    --------------
1554
1555    procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1556    begin
1557       Node.Left := Left;
1558    end Set_Left;
1559
1560    ----------------
1561    -- Set_Parent --
1562    ----------------
1563
1564    procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1565    begin
1566       Node.Parent := Parent;
1567    end Set_Parent;
1568
1569    ---------------
1570    -- Set_Right --
1571    ---------------
1572
1573    procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1574    begin
1575       Node.Right := Right;
1576    end Set_Right;
1577
1578    --------------------------
1579    -- Symmetric_Difference --
1580    --------------------------
1581
1582    procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1583    begin
1584       Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1585    end Symmetric_Difference;
1586
1587    function Symmetric_Difference (Left, Right : Set) return Set is
1588       Tree : constant Tree_Type :=
1589                Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1590    begin
1591       return Set'(Controlled with Tree);
1592    end Symmetric_Difference;
1593
1594    ------------
1595    -- To_Set --
1596    ------------
1597
1598    function To_Set (New_Item : Element_Type) return Set is
1599       Tree     : Tree_Type;
1600       Node     : Node_Access;
1601       Inserted : Boolean;
1602
1603    begin
1604       Insert_Sans_Hint (Tree, New_Item, Node, Inserted);
1605       return Set'(Controlled with Tree);
1606    end To_Set;
1607
1608    -----------
1609    -- Union --
1610    -----------
1611
1612    procedure Union (Target : in out Set; Source : Set) is
1613    begin
1614       Set_Ops.Union (Target.Tree, Source.Tree);
1615    end Union;
1616
1617    function Union (Left, Right : Set) return Set is
1618       Tree : constant Tree_Type :=
1619                Set_Ops.Union (Left.Tree, Right.Tree);
1620    begin
1621       return Set'(Controlled with Tree);
1622    end Union;
1623
1624    -----------
1625    -- Write --
1626    -----------
1627
1628    procedure Write
1629      (Stream    : access Root_Stream_Type'Class;
1630       Container : Set)
1631    is
1632       procedure Write_Node
1633         (Stream : access Root_Stream_Type'Class;
1634          Node   : Node_Access);
1635       pragma Inline (Write_Node);
1636
1637       procedure Write is
1638          new Tree_Operations.Generic_Write (Write_Node);
1639
1640       ----------------
1641       -- Write_Node --
1642       ----------------
1643
1644       procedure Write_Node
1645         (Stream : access Root_Stream_Type'Class;
1646          Node   : Node_Access)
1647       is
1648       begin
1649          Element_Type'Write (Stream, Node.Element);
1650       end Write_Node;
1651
1652    --  Start of processing for Write
1653
1654    begin
1655       Write (Stream, Container.Tree);
1656    end Write;
1657
1658    procedure Write
1659      (Stream : access Root_Stream_Type'Class;
1660       Item   : Cursor)
1661    is
1662    begin
1663       raise Program_Error;
1664    end Write;
1665
1666 end Ada.Containers.Ordered_Sets;