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