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