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