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-2014, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with Ada.Unchecked_Deallocation;
  31
  32 with Ada.Containers.Red_Black_Trees.Generic_Operations;
  33 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
  34
  35 with Ada.Containers.Red_Black_Trees.Generic_Keys;
  36 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
  37
  38 with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
  39 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
  40
  41 with System; use type System.Address;
  42
  43 package body Ada.Containers.Ordered_Sets is
  44
  45    ------------------------------
  46    -- Access to Fields of Node --
  47    ------------------------------
  48
  49    --  These subprograms provide functional notation for access to fields
  50    --  of a node, and procedural notation for modifying these fields.
  51
  52    function Color (Node : Node_Access) return Color_Type;
  53    pragma Inline (Color);
  54
  55    function Left (Node : Node_Access) return Node_Access;
  56    pragma Inline (Left);
  57
  58    function Parent (Node : Node_Access) return Node_Access;
  59    pragma Inline (Parent);
  60
  61    function Right (Node : Node_Access) return Node_Access;
  62    pragma Inline (Right);
  63
  64    procedure Set_Color (Node : Node_Access; Color : Color_Type);
  65    pragma Inline (Set_Color);
  66
  67    procedure Set_Left (Node : Node_Access; Left : Node_Access);
  68    pragma Inline (Set_Left);
  69
  70    procedure Set_Right (Node : Node_Access; Right : Node_Access);
  71    pragma Inline (Set_Right);
  72
  73    procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
  74    pragma Inline (Set_Parent);
  75
  76    -----------------------
  77    -- Local Subprograms --
  78    -----------------------
  79
  80    function Copy_Node (Source : Node_Access) return Node_Access;
  81    pragma Inline (Copy_Node);
  82
  83    procedure Free (X : in out Node_Access);
  84
  85    procedure Insert_Sans_Hint
  86      (Tree     : in out Tree_Type;
  87       New_Item : Element_Type;
  88       Node     : out Node_Access;
  89       Inserted : out Boolean);
  90
  91    procedure Insert_With_Hint
  92      (Dst_Tree : in out Tree_Type;
  93       Dst_Hint : Node_Access;
  94       Src_Node : Node_Access;
  95       Dst_Node : out Node_Access);
  96
  97    function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
  98    pragma Inline (Is_Equal_Node_Node);
  99
 100    function Is_Greater_Element_Node
 101      (Left  : Element_Type;
 102       Right : Node_Access) return Boolean;
 103    pragma Inline (Is_Greater_Element_Node);
 104
 105    function Is_Less_Element_Node
 106      (Left  : Element_Type;
 107       Right : Node_Access) return Boolean;
 108    pragma Inline (Is_Less_Element_Node);
 109
 110    function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
 111    pragma Inline (Is_Less_Node_Node);
 112
 113    procedure Replace_Element
 114      (Tree : in out Tree_Type;
 115       Node : Node_Access;
 116       Item : Element_Type);
 117
 118    --------------------------
 119    -- Local Instantiations --
 120    --------------------------
 121
 122    package Tree_Operations is
 123      new Red_Black_Trees.Generic_Operations (Tree_Types);
 124
 125    procedure Delete_Tree is
 126       new Tree_Operations.Generic_Delete_Tree (Free);
 127
 128    function Copy_Tree is
 129       new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
 130
 131    use Tree_Operations;
 132
 133    function Is_Equal is
 134      new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
 135
 136    package Element_Keys is
 137      new Red_Black_Trees.Generic_Keys
 138       (Tree_Operations     => Tree_Operations,
 139        Key_Type            => Element_Type,
 140        Is_Less_Key_Node    => Is_Less_Element_Node,
 141        Is_Greater_Key_Node => Is_Greater_Element_Node);
 142
 143    package Set_Ops is
 144      new Generic_Set_Operations
 145       (Tree_Operations  => Tree_Operations,
 146        Insert_With_Hint => Insert_With_Hint,
 147        Copy_Tree        => Copy_Tree,
 148        Delete_Tree      => Delete_Tree,
 149        Is_Less          => Is_Less_Node_Node,
 150        Free             => Free);
 151
 152    ---------
 153    -- "<" --
 154    ---------
 155
 156    function "<" (Left, Right : Cursor) return Boolean is
 157    begin
 158       if Left.Node = null then
 159          raise Constraint_Error with "Left cursor equals No_Element";
 160       end if;
 161
 162       if Right.Node = null then
 163          raise Constraint_Error with "Right cursor equals No_Element";
 164       end if;
 165
 166       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 167                      "bad Left cursor in ""<""");
 168
 169       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 170                      "bad Right cursor in ""<""");
 171
 172       return Left.Node.Element < Right.Node.Element;
 173    end "<";
 174
 175    function "<" (Left : Cursor; Right : Element_Type) return Boolean is
 176    begin
 177       if Left.Node = null then
 178          raise Constraint_Error with "Left cursor equals No_Element";
 179       end if;
 180
 181       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 182                      "bad Left cursor in ""<""");
 183
 184       return Left.Node.Element < Right;
 185    end "<";
 186
 187    function "<" (Left : Element_Type; Right : Cursor) return Boolean is
 188    begin
 189       if Right.Node = null then
 190          raise Constraint_Error with "Right cursor equals No_Element";
 191       end if;
 192
 193       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 194                      "bad Right cursor in ""<""");
 195
 196       return Left < Right.Node.Element;
 197    end "<";
 198
 199    ---------
 200    -- "=" --
 201    ---------
 202
 203    function "=" (Left, Right : Set) return Boolean is
 204    begin
 205       return Is_Equal (Left.Tree, Right.Tree);
 206    end "=";
 207
 208    ---------
 209    -- ">" --
 210    ---------
 211
 212    function ">" (Left, Right : Cursor) return Boolean is
 213    begin
 214       if Left.Node = null then
 215          raise Constraint_Error with "Left cursor equals No_Element";
 216       end if;
 217
 218       if Right.Node = null then
 219          raise Constraint_Error with "Right cursor equals No_Element";
 220       end if;
 221
 222       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 223                      "bad Left cursor in "">""");
 224
 225       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 226                      "bad Right cursor in "">""");
 227
 228       --  L > R same as R < L
 229
 230       return Right.Node.Element < Left.Node.Element;
 231    end ">";
 232
 233    function ">" (Left : Element_Type; Right : Cursor) return Boolean is
 234    begin
 235       if Right.Node = null then
 236          raise Constraint_Error with "Right cursor equals No_Element";
 237       end if;
 238
 239       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 240                      "bad Right cursor in "">""");
 241
 242       return Right.Node.Element < Left;
 243    end ">";
 244
 245    function ">" (Left : Cursor; Right : Element_Type) return Boolean is
 246    begin
 247       if Left.Node = null then
 248          raise Constraint_Error with "Left cursor equals No_Element";
 249       end if;
 250
 251       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 252                      "bad Left cursor in "">""");
 253
 254       return Right < Left.Node.Element;
 255    end ">";
 256
 257    ------------
 258    -- Adjust --
 259    ------------
 260
 261    procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree);
 262
 263    procedure Adjust (Container : in out Set) is
 264    begin
 265       Adjust (Container.Tree);
 266    end Adjust;
 267
 268    procedure Adjust (Control : in out Reference_Control_Type) is
 269    begin
 270       if Control.Container /= null then
 271          declare
 272             Tree : Tree_Type renames Control.Container.all.Tree;
 273             B : Natural renames Tree.Busy;
 274             L : Natural renames Tree.Lock;
 275          begin
 276             B := B + 1;
 277             L := L + 1;
 278          end;
 279       end if;
 280    end Adjust;
 281
 282    ------------
 283    -- Assign --
 284    ------------
 285
 286    procedure Assign (Target : in out Set; Source : Set) is
 287    begin
 288       if Target'Address = Source'Address then
 289          return;
 290       end if;
 291
 292       Target.Clear;
 293       Target.Union (Source);
 294    end Assign;
 295
 296    -------------
 297    -- Ceiling --
 298    -------------
 299
 300    function Ceiling (Container : Set; Item : Element_Type) return Cursor is
 301       Node : constant Node_Access :=
 302         Element_Keys.Ceiling (Container.Tree, Item);
 303    begin
 304       return (if Node = null then No_Element
 305               else Cursor'(Container'Unrestricted_Access, Node));
 306    end Ceiling;
 307
 308    -----------
 309    -- Clear --
 310    -----------
 311
 312    procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree);
 313
 314    procedure Clear (Container : in out Set) is
 315    begin
 316       Clear (Container.Tree);
 317    end Clear;
 318
 319    -----------
 320    -- Color --
 321    -----------
 322
 323    function Color (Node : Node_Access) return Color_Type is
 324    begin
 325       return Node.Color;
 326    end Color;
 327
 328    ------------------------
 329    -- Constant_Reference --
 330    ------------------------
 331
 332    function Constant_Reference
 333      (Container : aliased Set;
 334       Position  : Cursor) return Constant_Reference_Type
 335    is
 336    begin
 337       if Position.Container = null then
 338          raise Constraint_Error with "Position cursor has no element";
 339       end if;
 340
 341       if Position.Container /= Container'Unrestricted_Access then
 342          raise Program_Error with
 343            "Position cursor designates wrong container";
 344       end if;
 345
 346       pragma Assert
 347         (Vet (Container.Tree, Position.Node),
 348          "bad cursor in Constant_Reference");
 349
 350       declare
 351          Tree : Tree_Type renames Position.Container.all.Tree;
 352          B : Natural renames Tree.Busy;
 353          L : Natural renames Tree.Lock;
 354       begin
 355          return R : constant Constant_Reference_Type :=
 356            (Element => Position.Node.Element'Access,
 357             Control => (Controlled with Container'Unrestricted_Access))
 358          do
 359             B := B + 1;
 360             L := L + 1;
 361          end return;
 362       end;
 363    end Constant_Reference;
 364
 365    --------------
 366    -- Contains --
 367    --------------
 368
 369    function Contains
 370      (Container : Set;
 371       Item      : Element_Type) return Boolean
 372    is
 373    begin
 374       return Find (Container, Item) /= No_Element;
 375    end Contains;
 376
 377    ----------
 378    -- Copy --
 379    ----------
 380
 381    function Copy (Source : Set) return Set is
 382    begin
 383       return Target : Set do
 384          Target.Assign (Source);
 385       end return;
 386    end Copy;
 387
 388    ---------------
 389    -- Copy_Node --
 390    ---------------
 391
 392    function Copy_Node (Source : Node_Access) return Node_Access is
 393       Target : constant Node_Access :=
 394         new Node_Type'(Parent  => null,
 395                        Left    => null,
 396                        Right   => null,
 397                        Color   => Source.Color,
 398                        Element => Source.Element);
 399    begin
 400       return Target;
 401    end Copy_Node;
 402
 403    ------------
 404    -- Delete --
 405    ------------
 406
 407    procedure Delete (Container : in out Set; Position : in out Cursor) is
 408    begin
 409       if Position.Node = null then
 410          raise Constraint_Error with "Position cursor equals No_Element";
 411       end if;
 412
 413       if Position.Container /= Container'Unrestricted_Access then
 414          raise Program_Error with "Position cursor designates wrong set";
 415       end if;
 416
 417       pragma Assert (Vet (Container.Tree, Position.Node),
 418                      "bad cursor in Delete");
 419
 420       Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
 421       Free (Position.Node);
 422       Position.Container := null;
 423    end Delete;
 424
 425    procedure Delete (Container : in out Set; Item : Element_Type) is
 426       X : Node_Access := Element_Keys.Find (Container.Tree, Item);
 427
 428    begin
 429       if X = null then
 430          raise Constraint_Error with "attempt to delete element not in set";
 431       end if;
 432
 433       Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 434       Free (X);
 435    end Delete;
 436
 437    ------------------
 438    -- Delete_First --
 439    ------------------
 440
 441    procedure Delete_First (Container : in out Set) is
 442       Tree : Tree_Type renames Container.Tree;
 443       X    : Node_Access := Tree.First;
 444    begin
 445       if X /= null then
 446          Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 447          Free (X);
 448       end if;
 449    end Delete_First;
 450
 451    -----------------
 452    -- Delete_Last --
 453    -----------------
 454
 455    procedure Delete_Last (Container : in out Set) is
 456       Tree : Tree_Type renames Container.Tree;
 457       X    : Node_Access := Tree.Last;
 458    begin
 459       if X /= null then
 460          Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 461          Free (X);
 462       end if;
 463    end Delete_Last;
 464
 465    ----------------
 466    -- Difference --
 467    ----------------
 468
 469    procedure Difference (Target : in out Set; Source : Set) is
 470    begin
 471       Set_Ops.Difference (Target.Tree, Source.Tree);
 472    end Difference;
 473
 474    function Difference (Left, Right : Set) return Set is
 475       Tree : constant Tree_Type := Set_Ops.Difference (Left.Tree, Right.Tree);
 476    begin
 477       return Set'(Controlled with Tree);
 478    end Difference;
 479
 480    -------------
 481    -- Element --
 482    -------------
 483
 484    function Element (Position : Cursor) return Element_Type is
 485    begin
 486       if Position.Node = null then
 487          raise Constraint_Error with "Position cursor equals No_Element";
 488       end if;
 489
 490       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 491                      "bad cursor in Element");
 492
 493       return Position.Node.Element;
 494    end Element;
 495
 496    -------------------------
 497    -- Equivalent_Elements --
 498    -------------------------
 499
 500    function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
 501    begin
 502       return (if Left < Right or else Right < Left then False else True);
 503    end Equivalent_Elements;
 504
 505    ---------------------
 506    -- Equivalent_Sets --
 507    ---------------------
 508
 509    function Equivalent_Sets (Left, Right : Set) return Boolean is
 510       function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
 511       pragma Inline (Is_Equivalent_Node_Node);
 512
 513       function Is_Equivalent is
 514          new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
 515
 516       -----------------------------
 517       -- Is_Equivalent_Node_Node --
 518       -----------------------------
 519
 520       function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
 521       begin
 522          return (if L.Element < R.Element then False
 523                  elsif R.Element < L.Element then False
 524                  else True);
 525       end Is_Equivalent_Node_Node;
 526
 527    --  Start of processing for Equivalent_Sets
 528
 529    begin
 530       return Is_Equivalent (Left.Tree, Right.Tree);
 531    end Equivalent_Sets;
 532
 533    -------------
 534    -- Exclude --
 535    -------------
 536
 537    procedure Exclude (Container : in out Set; Item : Element_Type) is
 538       X : Node_Access := Element_Keys.Find (Container.Tree, Item);
 539
 540    begin
 541       if X /= null then
 542          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 543          Free (X);
 544       end if;
 545    end Exclude;
 546
 547    --------------
 548    -- Finalize --
 549    --------------
 550
 551    procedure Finalize (Object : in out Iterator) is
 552    begin
 553       if Object.Container /= null then
 554          declare
 555             B : Natural renames Object.Container.all.Tree.Busy;
 556          begin
 557             B := B - 1;
 558          end;
 559       end if;
 560    end Finalize;
 561
 562    procedure Finalize (Control : in out Reference_Control_Type) is
 563    begin
 564       if Control.Container /= null then
 565          declare
 566             Tree : Tree_Type renames Control.Container.all.Tree;
 567             B : Natural renames Tree.Busy;
 568             L : Natural renames Tree.Lock;
 569          begin
 570             B := B - 1;
 571             L := L - 1;
 572          end;
 573
 574          Control.Container := null;
 575       end if;
 576    end Finalize;
 577
 578    ----------
 579    -- Find --
 580    ----------
 581
 582    function Find (Container : Set; Item : Element_Type) return Cursor is
 583       Node : constant Node_Access := Element_Keys.Find (Container.Tree, Item);
 584    begin
 585       return (if Node = null then No_Element
 586               else Cursor'(Container'Unrestricted_Access, Node));
 587    end Find;
 588
 589    -----------
 590    -- First --
 591    -----------
 592
 593    function First (Container : Set) return Cursor is
 594    begin
 595       return
 596         (if Container.Tree.First = null then No_Element
 597          else Cursor'(Container'Unrestricted_Access, Container.Tree.First));
 598    end First;
 599
 600    function First (Object : Iterator) return Cursor is
 601    begin
 602       --  The value of the iterator object's Node component influences the
 603       --  behavior of the First (and Last) selector function.
 604
 605       --  When the Node component is null, this means the iterator object was
 606       --  constructed without a start expression, in which case the (forward)
 607       --  iteration starts from the (logical) beginning of the entire sequence
 608       --  of items (corresponding to Container.First, for a forward iterator).
 609
 610       --  Otherwise, this is iteration over a partial sequence of items. When
 611       --  the Node component is non-null, the iterator object was constructed
 612       --  with a start expression, that specifies the position from which the
 613       --  (forward) partial iteration begins.
 614
 615       if Object.Node = null then
 616          return Object.Container.First;
 617       else
 618          return Cursor'(Object.Container, Object.Node);
 619       end if;
 620    end First;
 621
 622    -------------------
 623    -- First_Element --
 624    -------------------
 625
 626    function First_Element (Container : Set) return Element_Type is
 627    begin
 628       if Container.Tree.First = null then
 629          raise Constraint_Error with "set is empty";
 630       end if;
 631
 632       return Container.Tree.First.Element;
 633    end First_Element;
 634
 635    -----------
 636    -- Floor --
 637    -----------
 638
 639    function Floor (Container : Set; Item : Element_Type) return Cursor is
 640       Node : constant Node_Access := Element_Keys.Floor (Container.Tree, Item);
 641    begin
 642       return (if Node = null then No_Element
 643               else Cursor'(Container'Unrestricted_Access, Node));
 644    end Floor;
 645
 646    ----------
 647    -- Free --
 648    ----------
 649
 650    procedure Free (X : in out Node_Access) is
 651       procedure Deallocate is
 652          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 653    begin
 654       if X /= null then
 655          X.Parent := X;
 656          X.Left   := X;
 657          X.Right  := X;
 658          Deallocate (X);
 659       end if;
 660    end Free;
 661
 662    ------------------
 663    -- Generic_Keys --
 664    ------------------
 665
 666    package body Generic_Keys is
 667
 668       -----------------------
 669       -- Local Subprograms --
 670       -----------------------
 671
 672       function Is_Greater_Key_Node
 673         (Left  : Key_Type;
 674          Right : Node_Access) return Boolean;
 675       pragma Inline (Is_Greater_Key_Node);
 676
 677       function Is_Less_Key_Node
 678         (Left  : Key_Type;
 679          Right : Node_Access) return Boolean;
 680       pragma Inline (Is_Less_Key_Node);
 681
 682       --------------------------
 683       -- Local Instantiations --
 684       --------------------------
 685
 686       package Key_Keys is
 687         new Red_Black_Trees.Generic_Keys
 688           (Tree_Operations     => Tree_Operations,
 689            Key_Type            => Key_Type,
 690            Is_Less_Key_Node    => Is_Less_Key_Node,
 691            Is_Greater_Key_Node => Is_Greater_Key_Node);
 692
 693       ------------
 694       -- Adjust --
 695       ------------
 696
 697       procedure Adjust (Control : in out Reference_Control_Type) is
 698       begin
 699          if Control.Container /= null then
 700             declare
 701                Tree : Tree_Type renames Control.Container.Tree;
 702                B : Natural renames Tree.Busy;
 703                L : Natural renames Tree.Lock;
 704             begin
 705                B := B + 1;
 706                L := L + 1;
 707             end;
 708          end if;
 709       end Adjust;
 710
 711       -------------
 712       -- Ceiling --
 713       -------------
 714
 715       function Ceiling (Container : Set; Key : Key_Type) return Cursor is
 716          Node : constant Node_Access := Key_Keys.Ceiling (Container.Tree, Key);
 717       begin
 718          return (if Node = null then No_Element
 719                  else Cursor'(Container'Unrestricted_Access, Node));
 720       end Ceiling;
 721
 722       ------------------------
 723       -- Constant_Reference --
 724       ------------------------
 725
 726       function Constant_Reference
 727         (Container : aliased Set;
 728          Key       : Key_Type) return Constant_Reference_Type
 729       is
 730          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 731
 732       begin
 733          if Node = null then
 734             raise Constraint_Error with "key not in set";
 735          end if;
 736
 737          declare
 738             Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree;
 739             B : Natural renames Tree.Busy;
 740             L : Natural renames Tree.Lock;
 741          begin
 742             return R : constant Constant_Reference_Type :=
 743               (Element => Node.Element'Access,
 744                Control => (Controlled with Container'Unrestricted_Access))
 745             do
 746                B := B + 1;
 747                L := L + 1;
 748             end return;
 749          end;
 750       end Constant_Reference;
 751
 752       --------------
 753       -- Contains --
 754       --------------
 755
 756       function Contains (Container : Set; Key : Key_Type) return Boolean is
 757       begin
 758          return Find (Container, Key) /= No_Element;
 759       end Contains;
 760
 761       ------------
 762       -- Delete --
 763       ------------
 764
 765       procedure Delete (Container : in out Set; Key : Key_Type) is
 766          X : Node_Access := Key_Keys.Find (Container.Tree, Key);
 767
 768       begin
 769          if X = null then
 770             raise Constraint_Error with "attempt to delete key not in set";
 771          end if;
 772
 773          Delete_Node_Sans_Free (Container.Tree, X);
 774          Free (X);
 775       end Delete;
 776
 777       -------------
 778       -- Element --
 779       -------------
 780
 781       function Element (Container : Set; Key : Key_Type) return Element_Type is
 782          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 783
 784       begin
 785          if Node = null then
 786             raise Constraint_Error with "key not in set";
 787          end if;
 788
 789          return Node.Element;
 790       end Element;
 791
 792       ---------------------
 793       -- Equivalent_Keys --
 794       ---------------------
 795
 796       function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
 797       begin
 798          return (if Left < Right or else Right < Left then False else True);
 799       end Equivalent_Keys;
 800
 801       -------------
 802       -- Exclude --
 803       -------------
 804
 805       procedure Exclude (Container : in out Set; Key : Key_Type) is
 806          X : Node_Access := Key_Keys.Find (Container.Tree, Key);
 807       begin
 808          if X /= null then
 809             Delete_Node_Sans_Free (Container.Tree, X);
 810             Free (X);
 811          end if;
 812       end Exclude;
 813
 814       --------------
 815       -- Finalize --
 816       --------------
 817
 818       procedure Finalize (Control : in out Reference_Control_Type) is
 819       begin
 820          if Control.Container /= null then
 821             declare
 822                Tree : Tree_Type renames Control.Container.Tree;
 823                B    : Natural renames Tree.Busy;
 824                L    : Natural renames Tree.Lock;
 825             begin
 826                B := B - 1;
 827                L := L - 1;
 828             end;
 829
 830             if not (Key (Control.Pos) = Control.Old_Key.all) then
 831                Delete (Control.Container.all, Key (Control.Pos));
 832                raise Program_Error;
 833             end if;
 834
 835             Control.Container := null;
 836             Control.Old_Key   := null;
 837          end if;
 838       end Finalize;
 839
 840       ----------
 841       -- Find --
 842       ----------
 843
 844       function Find (Container : Set; Key : Key_Type) return Cursor is
 845          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 846       begin
 847          return (if Node = null then No_Element
 848                  else Cursor'(Container'Unrestricted_Access, Node));
 849       end Find;
 850
 851       -----------
 852       -- Floor --
 853       -----------
 854
 855       function Floor (Container : Set; Key : Key_Type) return Cursor is
 856          Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
 857       begin
 858          return (if Node = null then No_Element
 859                  else Cursor'(Container'Unrestricted_Access, Node));
 860       end Floor;
 861
 862       -------------------------
 863       -- Is_Greater_Key_Node --
 864       -------------------------
 865
 866       function Is_Greater_Key_Node
 867         (Left  : Key_Type;
 868          Right : Node_Access) return Boolean
 869       is
 870       begin
 871          return Key (Right.Element) < Left;
 872       end Is_Greater_Key_Node;
 873
 874       ----------------------
 875       -- Is_Less_Key_Node --
 876       ----------------------
 877
 878       function Is_Less_Key_Node
 879         (Left  : Key_Type;
 880          Right : Node_Access) return Boolean
 881       is
 882       begin
 883          return Left < Key (Right.Element);
 884       end Is_Less_Key_Node;
 885
 886       ---------
 887       -- Key --
 888       ---------
 889
 890       function Key (Position : Cursor) return Key_Type is
 891       begin
 892          if Position.Node = null then
 893             raise Constraint_Error with
 894               "Position cursor equals No_Element";
 895          end if;
 896
 897          pragma Assert (Vet (Position.Container.Tree, Position.Node),
 898                         "bad cursor in Key");
 899
 900          return Key (Position.Node.Element);
 901       end Key;
 902
 903       ----------
 904       -- Read --
 905       ----------
 906
 907       procedure Read
 908         (Stream : not null access Root_Stream_Type'Class;
 909          Item   : out Reference_Type)
 910       is
 911       begin
 912          raise Program_Error with "attempt to stream reference";
 913       end Read;
 914
 915       ------------------------------
 916       -- Reference_Preserving_Key --
 917       ------------------------------
 918
 919       function Reference_Preserving_Key
 920         (Container : aliased in out Set;
 921          Position  : Cursor) return Reference_Type
 922       is
 923       begin
 924          if Position.Container = null then
 925             raise Constraint_Error with "Position cursor has no element";
 926          end if;
 927
 928          if Position.Container /= Container'Unrestricted_Access then
 929             raise Program_Error with
 930               "Position cursor designates wrong container";
 931          end if;
 932
 933          pragma Assert
 934            (Vet (Container.Tree, Position.Node),
 935             "bad cursor in function Reference_Preserving_Key");
 936
 937          declare
 938             Tree : Tree_Type renames Container.Tree;
 939             B : Natural renames Tree.Busy;
 940             L : Natural renames Tree.Lock;
 941
 942          begin
 943             return R : constant Reference_Type :=
 944               (Element  => Position.Node.Element'Access,
 945                  Control =>
 946                    (Controlled with
 947                      Container => Container'Access,
 948                      Pos       => Position,
 949                      Old_Key   => new Key_Type'(Key (Position))))
 950             do
 951                B := B + 1;
 952                L := L + 1;
 953             end return;
 954          end;
 955       end Reference_Preserving_Key;
 956
 957       function Reference_Preserving_Key
 958         (Container : aliased in out Set;
 959          Key       : Key_Type) return Reference_Type
 960       is
 961          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 962
 963       begin
 964          if Node = null then
 965             raise Constraint_Error with "key not in set";
 966          end if;
 967
 968          declare
 969             Tree : Tree_Type renames Container.Tree;
 970             B : Natural renames Tree.Busy;
 971             L : Natural renames Tree.Lock;
 972
 973          begin
 974             return R : constant Reference_Type :=
 975               (Element  => Node.Element'Access,
 976                  Control =>
 977                    (Controlled with
 978                      Container => Container'Access,
 979                      Pos       => Find (Container, Key),
 980                      Old_Key   => new Key_Type'(Key)))
 981             do
 982                B := B + 1;
 983                L := L + 1;
 984             end return;
 985          end;
 986       end Reference_Preserving_Key;
 987
 988       -------------
 989       -- Replace --
 990       -------------
 991
 992       procedure Replace
 993         (Container : in out Set;
 994          Key       : Key_Type;
 995          New_Item  : Element_Type)
 996       is
 997          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 998
 999       begin
1000          if Node = null then
1001             raise Constraint_Error with
1002               "attempt to replace key not in set";
1003          end if;
1004
1005          Replace_Element (Container.Tree, Node, New_Item);
1006       end Replace;
1007
1008       -----------------------------------
1009       -- Update_Element_Preserving_Key --
1010       -----------------------------------
1011
1012       procedure Update_Element_Preserving_Key
1013         (Container : in out Set;
1014          Position  : Cursor;
1015          Process   : not null access procedure (Element : in out Element_Type))
1016       is
1017          Tree : Tree_Type renames Container.Tree;
1018
1019       begin
1020          if Position.Node = null then
1021             raise Constraint_Error with
1022               "Position cursor equals No_Element";
1023          end if;
1024
1025          if Position.Container /= Container'Unrestricted_Access then
1026             raise Program_Error with
1027               "Position cursor designates wrong set";
1028          end if;
1029
1030          pragma Assert (Vet (Container.Tree, Position.Node),
1031                         "bad cursor in Update_Element_Preserving_Key");
1032
1033          declare
1034             E : Element_Type renames Position.Node.Element;
1035             K : constant Key_Type := Key (E);
1036
1037             B : Natural renames Tree.Busy;
1038             L : Natural renames Tree.Lock;
1039
1040             Eq : Boolean;
1041
1042          begin
1043             B := B + 1;
1044             L := L + 1;
1045
1046             begin
1047                Process (E);
1048                Eq := Equivalent_Keys (K, Key (E));
1049             exception
1050                when others =>
1051                   L := L - 1;
1052                   B := B - 1;
1053                   raise;
1054             end;
1055
1056             L := L - 1;
1057             B := B - 1;
1058
1059             if Eq then
1060                return;
1061             end if;
1062          end;
1063
1064          declare
1065             X : Node_Access := Position.Node;
1066          begin
1067             Tree_Operations.Delete_Node_Sans_Free (Tree, X);
1068             Free (X);
1069          end;
1070
1071          raise Program_Error with "key was modified";
1072       end Update_Element_Preserving_Key;
1073
1074       -----------
1075       -- Write --
1076       -----------
1077
1078       procedure Write
1079         (Stream : not null access Root_Stream_Type'Class;
1080          Item   : Reference_Type)
1081       is
1082       begin
1083          raise Program_Error with "attempt to stream reference";
1084       end Write;
1085
1086    end Generic_Keys;
1087
1088    -----------------
1089    -- Has_Element --
1090    -----------------
1091
1092    function Has_Element (Position : Cursor) return Boolean is
1093    begin
1094       return Position /= No_Element;
1095    end Has_Element;
1096
1097    -------------
1098    -- Include --
1099    -------------
1100
1101    procedure Include (Container : in out Set; New_Item : Element_Type) is
1102       Position : Cursor;
1103       Inserted : Boolean;
1104
1105    begin
1106       Insert (Container, New_Item, Position, Inserted);
1107
1108       if not Inserted then
1109          if Container.Tree.Lock > 0 then
1110             raise Program_Error with
1111               "attempt to tamper with elements (set is locked)";
1112          end if;
1113
1114          Position.Node.Element := New_Item;
1115       end if;
1116    end Include;
1117
1118    ------------
1119    -- Insert --
1120    ------------
1121
1122    procedure Insert
1123      (Container : in out Set;
1124       New_Item  : Element_Type;
1125       Position  : out Cursor;
1126       Inserted  : out Boolean)
1127    is
1128    begin
1129       Insert_Sans_Hint
1130         (Container.Tree,
1131          New_Item,
1132          Position.Node,
1133          Inserted);
1134
1135       Position.Container := Container'Unrestricted_Access;
1136    end Insert;
1137
1138    procedure Insert
1139      (Container : in out Set;
1140       New_Item  : Element_Type)
1141    is
1142       Position : Cursor;
1143       pragma Unreferenced (Position);
1144
1145       Inserted : Boolean;
1146
1147    begin
1148       Insert (Container, New_Item, Position, Inserted);
1149
1150       if not Inserted then
1151          raise Constraint_Error with
1152            "attempt to insert element already in set";
1153       end if;
1154    end Insert;
1155
1156    ----------------------
1157    -- Insert_Sans_Hint --
1158    ----------------------
1159
1160    procedure Insert_Sans_Hint
1161      (Tree     : in out Tree_Type;
1162       New_Item : Element_Type;
1163       Node     : out Node_Access;
1164       Inserted : out Boolean)
1165    is
1166       function New_Node return Node_Access;
1167       pragma Inline (New_Node);
1168
1169       procedure Insert_Post is
1170         new Element_Keys.Generic_Insert_Post (New_Node);
1171
1172       procedure Conditional_Insert_Sans_Hint is
1173         new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1174
1175       --------------
1176       -- New_Node --
1177       --------------
1178
1179       function New_Node return Node_Access is
1180       begin
1181          return new Node_Type'(Parent  => null,
1182                                Left    => null,
1183                                Right   => null,
1184                                Color   => Red_Black_Trees.Red,
1185                                Element => New_Item);
1186       end New_Node;
1187
1188    --  Start of processing for Insert_Sans_Hint
1189
1190    begin
1191       Conditional_Insert_Sans_Hint
1192         (Tree,
1193          New_Item,
1194          Node,
1195          Inserted);
1196    end Insert_Sans_Hint;
1197
1198    ----------------------
1199    -- Insert_With_Hint --
1200    ----------------------
1201
1202    procedure Insert_With_Hint
1203      (Dst_Tree : in out Tree_Type;
1204       Dst_Hint : Node_Access;
1205       Src_Node : Node_Access;
1206       Dst_Node : out Node_Access)
1207    is
1208       Success : Boolean;
1209       pragma Unreferenced (Success);
1210
1211       function New_Node return Node_Access;
1212       pragma Inline (New_Node);
1213
1214       procedure Insert_Post is
1215         new Element_Keys.Generic_Insert_Post (New_Node);
1216
1217       procedure Insert_Sans_Hint is
1218         new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1219
1220       procedure Local_Insert_With_Hint is
1221         new Element_Keys.Generic_Conditional_Insert_With_Hint
1222           (Insert_Post,
1223            Insert_Sans_Hint);
1224
1225       --------------
1226       -- New_Node --
1227       --------------
1228
1229       function New_Node return Node_Access is
1230          Node : constant Node_Access :=
1231            new Node_Type'(Parent  => null,
1232                           Left    => null,
1233                           Right   => null,
1234                           Color   => Red,
1235                           Element => Src_Node.Element);
1236       begin
1237          return Node;
1238       end New_Node;
1239
1240    --  Start of processing for Insert_With_Hint
1241
1242    begin
1243       Local_Insert_With_Hint
1244         (Dst_Tree,
1245          Dst_Hint,
1246          Src_Node.Element,
1247          Dst_Node,
1248          Success);
1249    end Insert_With_Hint;
1250
1251    ------------------
1252    -- Intersection --
1253    ------------------
1254
1255    procedure Intersection (Target : in out Set; Source : Set) is
1256    begin
1257       Set_Ops.Intersection (Target.Tree, Source.Tree);
1258    end Intersection;
1259
1260    function Intersection (Left, Right : Set) return Set is
1261       Tree : constant Tree_Type :=
1262         Set_Ops.Intersection (Left.Tree, Right.Tree);
1263    begin
1264       return Set'(Controlled with Tree);
1265    end Intersection;
1266
1267    --------------
1268    -- Is_Empty --
1269    --------------
1270
1271    function Is_Empty (Container : Set) return Boolean is
1272    begin
1273       return Container.Tree.Length = 0;
1274    end Is_Empty;
1275
1276    ------------------------
1277    -- Is_Equal_Node_Node --
1278    ------------------------
1279
1280    function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1281    begin
1282       return L.Element = R.Element;
1283    end Is_Equal_Node_Node;
1284
1285    -----------------------------
1286    -- Is_Greater_Element_Node --
1287    -----------------------------
1288
1289    function Is_Greater_Element_Node
1290      (Left  : Element_Type;
1291       Right : Node_Access) return Boolean
1292    is
1293    begin
1294       --  Compute e > node same as node < e
1295
1296       return Right.Element < Left;
1297    end Is_Greater_Element_Node;
1298
1299    --------------------------
1300    -- Is_Less_Element_Node --
1301    --------------------------
1302
1303    function Is_Less_Element_Node
1304      (Left  : Element_Type;
1305       Right : Node_Access) return Boolean
1306    is
1307    begin
1308       return Left < Right.Element;
1309    end Is_Less_Element_Node;
1310
1311    -----------------------
1312    -- Is_Less_Node_Node --
1313    -----------------------
1314
1315    function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1316    begin
1317       return L.Element < R.Element;
1318    end Is_Less_Node_Node;
1319
1320    ---------------
1321    -- Is_Subset --
1322    ---------------
1323
1324    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1325    begin
1326       return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1327    end Is_Subset;
1328
1329    -------------
1330    -- Iterate --
1331    -------------
1332
1333    procedure Iterate
1334      (Container : Set;
1335       Process   : not null access procedure (Position : Cursor))
1336    is
1337       procedure Process_Node (Node : Node_Access);
1338       pragma Inline (Process_Node);
1339
1340       procedure Local_Iterate is
1341         new Tree_Operations.Generic_Iteration (Process_Node);
1342
1343       ------------------
1344       -- Process_Node --
1345       ------------------
1346
1347       procedure Process_Node (Node : Node_Access) is
1348       begin
1349          Process (Cursor'(Container'Unrestricted_Access, Node));
1350       end Process_Node;
1351
1352       T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
1353       B : Natural renames T.Busy;
1354
1355    --  Start of processing for Iterate
1356
1357    begin
1358       B := B + 1;
1359
1360       begin
1361          Local_Iterate (T);
1362       exception
1363          when others =>
1364             B := B - 1;
1365             raise;
1366       end;
1367
1368       B := B - 1;
1369    end Iterate;
1370
1371    function Iterate (Container : Set)
1372      return Set_Iterator_Interfaces.Reversible_Iterator'Class
1373    is
1374       B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
1375
1376    begin
1377       --  The value of the Node component influences the behavior of the First
1378       --  and Last selector functions of the iterator object. When the Node
1379       --  component is null (as is the case here), this means the iterator
1380       --  object was constructed without a start expression. This is a complete
1381       --  iterator, meaning that the iteration starts from the (logical)
1382       --  beginning of the sequence of items.
1383
1384       --  Note: For a forward iterator, Container.First is the beginning, and
1385       --  for a reverse iterator, Container.Last is the beginning.
1386
1387       B := B + 1;
1388
1389       return It : constant Iterator :=
1390         Iterator'(Limited_Controlled with
1391                     Container => Container'Unrestricted_Access,
1392                     Node      => null);
1393    end Iterate;
1394
1395    function Iterate (Container : Set; Start : Cursor)
1396      return Set_Iterator_Interfaces.Reversible_Iterator'Class
1397    is
1398       B  : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
1399
1400    begin
1401       --  It was formerly the case that when Start = No_Element, the partial
1402       --  iterator was defined to behave the same as for a complete iterator,
1403       --  and iterate over the entire sequence of items. However, those
1404       --  semantics were unintuitive and arguably error-prone (it is too easy
1405       --  to accidentally create an endless loop), and so they were changed,
1406       --  per the ARG meeting in Denver on 2011/11. However, there was no
1407       --  consensus about what positive meaning this corner case should have,
1408       --  and so it was decided to simply raise an exception. This does imply,
1409       --  however, that it is not possible to use a partial iterator to specify
1410       --  an empty sequence of items.
1411
1412       if Start = No_Element then
1413          raise Constraint_Error with
1414            "Start position for iterator equals No_Element";
1415       end if;
1416
1417       if Start.Container /= Container'Unrestricted_Access then
1418          raise Program_Error with
1419            "Start cursor of Iterate designates wrong set";
1420       end if;
1421
1422       pragma Assert (Vet (Container.Tree, Start.Node),
1423                      "Start cursor of Iterate is bad");
1424
1425       --  The value of the Node component influences the behavior of the First
1426       --  and Last selector functions of the iterator object. When the Node
1427       --  component is non-null (as is the case here), it means that this is a
1428       --  partial iteration, over a subset of the complete sequence of
1429       --  items. The iterator object was constructed with a start expression,
1430       --  indicating the position from which the iteration begins. Note that
1431       --  the start position has the same value irrespective of whether this is
1432       --  a forward or reverse iteration.
1433
1434       B := B + 1;
1435
1436       return It : constant Iterator :=
1437         Iterator'(Limited_Controlled with
1438                     Container => Container'Unrestricted_Access,
1439                     Node      => Start.Node);
1440    end Iterate;
1441
1442    ----------
1443    -- Last --
1444    ----------
1445
1446    function Last (Container : Set) return Cursor is
1447    begin
1448       return
1449         (if Container.Tree.Last = null then No_Element
1450          else Cursor'(Container'Unrestricted_Access, Container.Tree.Last));
1451    end Last;
1452
1453    function Last (Object : Iterator) return Cursor is
1454    begin
1455       --  The value of the iterator object's Node component influences the
1456       --  behavior of the Last (and First) selector function.
1457
1458       --  When the Node component is null, this means the iterator object was
1459       --  constructed without a start expression, in which case the (reverse)
1460       --  iteration starts from the (logical) beginning of the entire sequence
1461       --  (corresponding to Container.Last, for a reverse iterator).
1462
1463       --  Otherwise, this is iteration over a partial sequence of items. When
1464       --  the Node component is non-null, the iterator object was constructed
1465       --  with a start expression, that specifies the position from which the
1466       --  (reverse) partial iteration begins.
1467
1468       if Object.Node = null then
1469          return Object.Container.Last;
1470       else
1471          return Cursor'(Object.Container, Object.Node);
1472       end if;
1473    end Last;
1474
1475    ------------------
1476    -- Last_Element --
1477    ------------------
1478
1479    function Last_Element (Container : Set) return Element_Type is
1480    begin
1481       if Container.Tree.Last = null then
1482          raise Constraint_Error with "set is empty";
1483       else
1484          return Container.Tree.Last.Element;
1485       end if;
1486    end Last_Element;
1487
1488    ----------
1489    -- Left --
1490    ----------
1491
1492    function Left (Node : Node_Access) return Node_Access is
1493    begin
1494       return Node.Left;
1495    end Left;
1496
1497    ------------
1498    -- Length --
1499    ------------
1500
1501    function Length (Container : Set) return Count_Type is
1502    begin
1503       return Container.Tree.Length;
1504    end Length;
1505
1506    ----------
1507    -- Move --
1508    ----------
1509
1510    procedure Move is new Tree_Operations.Generic_Move (Clear);
1511
1512    procedure Move (Target : in out Set; Source : in out Set) is
1513    begin
1514       Move (Target => Target.Tree, Source => Source.Tree);
1515    end Move;
1516
1517    ----------
1518    -- Next --
1519    ----------
1520
1521    function Next (Position : Cursor) return Cursor is
1522    begin
1523       if Position = No_Element then
1524          return No_Element;
1525       end if;
1526
1527       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1528                      "bad cursor in Next");
1529
1530       declare
1531          Node : constant Node_Access :=
1532            Tree_Operations.Next (Position.Node);
1533       begin
1534          return (if Node = null then No_Element
1535                  else Cursor'(Position.Container, Node));
1536       end;
1537    end Next;
1538
1539    procedure Next (Position : in out Cursor) is
1540    begin
1541       Position := Next (Position);
1542    end Next;
1543
1544    function Next (Object : Iterator; Position : Cursor) return Cursor is
1545    begin
1546       if Position.Container = null then
1547          return No_Element;
1548       end if;
1549
1550       if Position.Container /= Object.Container then
1551          raise Program_Error with
1552            "Position cursor of Next designates wrong set";
1553       end if;
1554
1555       return Next (Position);
1556    end Next;
1557
1558    -------------
1559    -- Overlap --
1560    -------------
1561
1562    function Overlap (Left, Right : Set) return Boolean is
1563    begin
1564       return Set_Ops.Overlap (Left.Tree, Right.Tree);
1565    end Overlap;
1566
1567    ------------
1568    -- Parent --
1569    ------------
1570
1571    function Parent (Node : Node_Access) return Node_Access is
1572    begin
1573       return Node.Parent;
1574    end Parent;
1575
1576    --------------
1577    -- Previous --
1578    --------------
1579
1580    function Previous (Position : Cursor) return Cursor is
1581    begin
1582       if Position = No_Element then
1583          return No_Element;
1584       end if;
1585
1586       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1587                      "bad cursor in Previous");
1588
1589       declare
1590          Node : constant Node_Access :=
1591            Tree_Operations.Previous (Position.Node);
1592       begin
1593          return (if Node = null then No_Element
1594                  else Cursor'(Position.Container, Node));
1595       end;
1596    end Previous;
1597
1598    procedure Previous (Position : in out Cursor) is
1599    begin
1600       Position := Previous (Position);
1601    end Previous;
1602
1603    function Previous (Object : Iterator; Position : Cursor) return Cursor is
1604    begin
1605       if Position.Container = null then
1606          return No_Element;
1607       end if;
1608
1609       if Position.Container /= Object.Container then
1610          raise Program_Error with
1611            "Position cursor of Previous designates wrong set";
1612       end if;
1613
1614       return Previous (Position);
1615    end Previous;
1616
1617    -------------------
1618    -- Query_Element --
1619    -------------------
1620
1621    procedure Query_Element
1622      (Position : Cursor;
1623       Process  : not null access procedure (Element : Element_Type))
1624    is
1625    begin
1626       if Position.Node = null then
1627          raise Constraint_Error with "Position cursor equals No_Element";
1628       end if;
1629
1630       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1631                      "bad cursor in Query_Element");
1632
1633       declare
1634          T : Tree_Type renames Position.Container.Tree;
1635
1636          B : Natural renames T.Busy;
1637          L : Natural renames T.Lock;
1638
1639       begin
1640          B := B + 1;
1641          L := L + 1;
1642
1643          begin
1644             Process (Position.Node.Element);
1645          exception
1646             when others =>
1647                L := L - 1;
1648                B := B - 1;
1649                raise;
1650          end;
1651
1652          L := L - 1;
1653          B := B - 1;
1654       end;
1655    end Query_Element;
1656
1657    ----------
1658    -- Read --
1659    ----------
1660
1661    procedure Read
1662      (Stream    : not null access Root_Stream_Type'Class;
1663       Container : out Set)
1664    is
1665       function Read_Node
1666         (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1667       pragma Inline (Read_Node);
1668
1669       procedure Read is
1670          new Tree_Operations.Generic_Read (Clear, Read_Node);
1671
1672       ---------------
1673       -- Read_Node --
1674       ---------------
1675
1676       function Read_Node
1677         (Stream : not null access Root_Stream_Type'Class) return Node_Access
1678       is
1679          Node : Node_Access := new Node_Type;
1680       begin
1681          Element_Type'Read (Stream, Node.Element);
1682          return Node;
1683       exception
1684          when others =>
1685             Free (Node);
1686             raise;
1687       end Read_Node;
1688
1689    --  Start of processing for Read
1690
1691    begin
1692       Read (Stream, Container.Tree);
1693    end Read;
1694
1695    procedure Read
1696      (Stream : not null access Root_Stream_Type'Class;
1697       Item   : out Cursor)
1698    is
1699    begin
1700       raise Program_Error with "attempt to stream set cursor";
1701    end Read;
1702
1703    procedure Read
1704      (Stream : not null access Root_Stream_Type'Class;
1705       Item   : out Constant_Reference_Type)
1706    is
1707    begin
1708       raise Program_Error with "attempt to stream reference";
1709    end Read;
1710
1711    -------------
1712    -- Replace --
1713    -------------
1714
1715    procedure Replace (Container : in out Set; New_Item : Element_Type) is
1716       Node : constant Node_Access :=
1717         Element_Keys.Find (Container.Tree, New_Item);
1718
1719    begin
1720       if Node = null then
1721          raise Constraint_Error with
1722            "attempt to replace element not in set";
1723       end if;
1724
1725       if Container.Tree.Lock > 0 then
1726          raise Program_Error with
1727            "attempt to tamper with elements (set is locked)";
1728       end if;
1729
1730       Node.Element := New_Item;
1731    end Replace;
1732
1733    ---------------------
1734    -- Replace_Element --
1735    ---------------------
1736
1737    procedure Replace_Element
1738      (Tree : in out Tree_Type;
1739       Node : Node_Access;
1740       Item : Element_Type)
1741    is
1742       pragma Assert (Node /= null);
1743
1744       function New_Node return Node_Access;
1745       pragma Inline (New_Node);
1746
1747       procedure Local_Insert_Post is
1748          new Element_Keys.Generic_Insert_Post (New_Node);
1749
1750       procedure Local_Insert_Sans_Hint is
1751          new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
1752
1753       procedure Local_Insert_With_Hint is
1754          new Element_Keys.Generic_Conditional_Insert_With_Hint
1755         (Local_Insert_Post,
1756          Local_Insert_Sans_Hint);
1757
1758       --------------
1759       -- New_Node --
1760       --------------
1761
1762       function New_Node return Node_Access is
1763       begin
1764          Node.Element := Item;
1765          Node.Color   := Red;
1766          Node.Parent  := null;
1767          Node.Right   := null;
1768          Node.Left    := null;
1769          return Node;
1770       end New_Node;
1771
1772       Hint     : Node_Access;
1773       Result   : Node_Access;
1774       Inserted : Boolean;
1775       Compare  : Boolean;
1776
1777       --  Per AI05-0022, the container implementation is required to detect
1778       --  element tampering by a generic actual subprogram.
1779
1780       B : Natural renames Tree.Busy;
1781       L : Natural renames Tree.Lock;
1782
1783    --  Start of processing for Replace_Element
1784
1785    begin
1786       --  Replace_Element assigns value Item to the element designated by Node,
1787       --  per certain semantic constraints.
1788
1789       --  If Item is equivalent to the element, then element is replaced and
1790       --  there's nothing else to do. This is the easy case.
1791
1792       --  If Item is not equivalent, then the node will (possibly) have to move
1793       --  to some other place in the tree. This is slighly more complicated,
1794       --  because we must ensure that Item is not equivalent to some other
1795       --  element in the tree (in which case, the replacement is not allowed).
1796
1797       --  Determine whether Item is equivalent to element on the specified
1798       --  node.
1799
1800       begin
1801          B := B + 1;
1802          L := L + 1;
1803
1804          Compare := (if Item < Node.Element then False
1805                      elsif Node.Element < Item then False
1806                      else True);
1807
1808          L := L - 1;
1809          B := B - 1;
1810
1811       exception
1812          when others =>
1813             L := L - 1;
1814             B := B - 1;
1815
1816             raise;
1817       end;
1818
1819       if Compare then
1820          --  Item is equivalent to the node's element, so we will not have to
1821          --  move the node.
1822
1823          if Tree.Lock > 0 then
1824             raise Program_Error with
1825               "attempt to tamper with elements (set is locked)";
1826          end if;
1827
1828          Node.Element := Item;
1829          return;
1830       end if;
1831
1832       --  The replacement Item is not equivalent to the element on the
1833       --  specified node, which means that it will need to be re-inserted in a
1834       --  different position in the tree. We must now determine whether Item is
1835       --  equivalent to some other element in the tree (which would prohibit
1836       --  the assignment and hence the move).
1837
1838       --  Ceiling returns the smallest element equivalent or greater than the
1839       --  specified Item; if there is no such element, then it returns null.
1840
1841       Hint := Element_Keys.Ceiling (Tree, Item);
1842
1843       if Hint /= null then
1844          begin
1845             B := B + 1;
1846             L := L + 1;
1847
1848             Compare := Item < Hint.Element;
1849
1850             L := L - 1;
1851             B := B - 1;
1852
1853          exception
1854             when others =>
1855                L := L - 1;
1856                B := B - 1;
1857
1858                raise;
1859          end;
1860
1861          --  Item >= Hint.Element
1862
1863          if not Compare then
1864
1865             --  Ceiling returns an element that is equivalent or greater
1866             --  than Item. If Item is "not less than" the element, then
1867             --  by elimination we know that Item is equivalent to the element.
1868
1869             --  But this means that it is not possible to assign the value of
1870             --  Item to the specified element (on Node), because a different
1871             --  element (on Hint) equivalent to Item already exsits. (Were we
1872             --  to change Node's element value, we would have to move Node, but
1873             --  we would be unable to move the Node, because its new position
1874             --  in the tree is already occupied by an equivalent element.)
1875
1876             raise Program_Error with "attempt to replace existing element";
1877          end if;
1878
1879          --  Item is not equivalent to any other element in the tree, so it is
1880          --  safe to assign the value of Item to Node.Element. This means that
1881          --  the node will have to move to a different position in the tree
1882          --  (because its element will have a different value).
1883
1884          --  The nearest (greater) neighbor of Item is Hint. This will be the
1885          --  insertion position of Node (because its element will have Item as
1886          --  its new value).
1887
1888          --  If Node equals Hint, the relative position of Node does not
1889          --  change. This allows us to perform an optimization: we need not
1890          --  remove Node from the tree and then reinsert it with its new value,
1891          --  because it would only be placed in the exact same position.
1892
1893          if Hint = Node then
1894             if Tree.Lock > 0 then
1895                raise Program_Error with
1896                  "attempt to tamper with elements (set is locked)";
1897             end if;
1898
1899             Node.Element := Item;
1900             return;
1901          end if;
1902       end if;
1903
1904       --  If we get here, it is because Item was greater than all elements in
1905       --  the tree (Hint = null), or because Item was less than some element at
1906       --  a different place in the tree (Item < Hint.Element). In either case,
1907       --  we remove Node from the tree (without actually deallocating it), and
1908       --  then insert Item into the tree, onto the same Node (so no new node is
1909       --  actually allocated).
1910
1911       Tree_Operations.Delete_Node_Sans_Free (Tree, Node);  -- Checks busy-bit
1912
1913       Local_Insert_With_Hint  -- use unconditional insert here instead???
1914         (Tree     => Tree,
1915          Position => Hint,
1916          Key      => Item,
1917          Node     => Result,
1918          Inserted => Inserted);
1919
1920       pragma Assert (Inserted);
1921       pragma Assert (Result = Node);
1922    end Replace_Element;
1923
1924    procedure Replace_Element
1925      (Container : in out Set;
1926       Position  : Cursor;
1927       New_Item  : Element_Type)
1928    is
1929    begin
1930       if Position.Node = null then
1931          raise Constraint_Error with
1932            "Position cursor equals No_Element";
1933       end if;
1934
1935       if Position.Container /= Container'Unrestricted_Access then
1936          raise Program_Error with
1937            "Position cursor designates wrong set";
1938       end if;
1939
1940       pragma Assert (Vet (Container.Tree, Position.Node),
1941                      "bad cursor in Replace_Element");
1942
1943       Replace_Element (Container.Tree, Position.Node, New_Item);
1944    end Replace_Element;
1945
1946    ---------------------
1947    -- Reverse_Iterate --
1948    ---------------------
1949
1950    procedure Reverse_Iterate
1951      (Container : Set;
1952       Process   : not null access procedure (Position : Cursor))
1953    is
1954       procedure Process_Node (Node : Node_Access);
1955       pragma Inline (Process_Node);
1956
1957       procedure Local_Reverse_Iterate is
1958          new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1959
1960       ------------------
1961       -- Process_Node --
1962       ------------------
1963
1964       procedure Process_Node (Node : Node_Access) is
1965       begin
1966          Process (Cursor'(Container'Unrestricted_Access, Node));
1967       end Process_Node;
1968
1969       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1970       B : Natural renames T.Busy;
1971
1972    --  Start of processing for Reverse_Iterate
1973
1974    begin
1975       B := B + 1;
1976
1977       begin
1978          Local_Reverse_Iterate (T);
1979       exception
1980          when others =>
1981             B := B - 1;
1982             raise;
1983       end;
1984
1985       B := B - 1;
1986    end Reverse_Iterate;
1987
1988    -----------
1989    -- Right --
1990    -----------
1991
1992    function Right (Node : Node_Access) return Node_Access is
1993    begin
1994       return Node.Right;
1995    end Right;
1996
1997    ---------------
1998    -- Set_Color --
1999    ---------------
2000
2001    procedure Set_Color (Node : Node_Access; Color : Color_Type) is
2002    begin
2003       Node.Color := Color;
2004    end Set_Color;
2005
2006    --------------
2007    -- Set_Left --
2008    --------------
2009
2010    procedure Set_Left (Node : Node_Access; Left : Node_Access) is
2011    begin
2012       Node.Left := Left;
2013    end Set_Left;
2014
2015    ----------------
2016    -- Set_Parent --
2017    ----------------
2018
2019    procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
2020    begin
2021       Node.Parent := Parent;
2022    end Set_Parent;
2023
2024    ---------------
2025    -- Set_Right --
2026    ---------------
2027
2028    procedure Set_Right (Node : Node_Access; Right : Node_Access) is
2029    begin
2030       Node.Right := Right;
2031    end Set_Right;
2032
2033    --------------------------
2034    -- Symmetric_Difference --
2035    --------------------------
2036
2037    procedure Symmetric_Difference (Target : in out Set; Source : Set) is
2038    begin
2039       Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
2040    end Symmetric_Difference;
2041
2042    function Symmetric_Difference (Left, Right : Set) return Set is
2043       Tree : constant Tree_Type :=
2044         Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
2045    begin
2046       return Set'(Controlled with Tree);
2047    end Symmetric_Difference;
2048
2049    ------------
2050    -- To_Set --
2051    ------------
2052
2053    function To_Set (New_Item : Element_Type) return Set is
2054       Tree     : Tree_Type;
2055       Node     : Node_Access;
2056       Inserted : Boolean;
2057       pragma Unreferenced (Node, Inserted);
2058    begin
2059       Insert_Sans_Hint (Tree, New_Item, Node, Inserted);
2060       return Set'(Controlled with Tree);
2061    end To_Set;
2062
2063    -----------
2064    -- Union --
2065    -----------
2066
2067    procedure Union (Target : in out Set; Source : Set) is
2068    begin
2069       Set_Ops.Union (Target.Tree, Source.Tree);
2070    end Union;
2071
2072    function Union (Left, Right : Set) return Set is
2073       Tree : constant Tree_Type :=
2074         Set_Ops.Union (Left.Tree, Right.Tree);
2075    begin
2076       return Set'(Controlled with Tree);
2077    end Union;
2078
2079    -----------
2080    -- Write --
2081    -----------
2082
2083    procedure Write
2084      (Stream    : not null access Root_Stream_Type'Class;
2085       Container : Set)
2086    is
2087       procedure Write_Node
2088         (Stream : not null access Root_Stream_Type'Class;
2089          Node   : Node_Access);
2090       pragma Inline (Write_Node);
2091
2092       procedure Write is
2093          new Tree_Operations.Generic_Write (Write_Node);
2094
2095       ----------------
2096       -- Write_Node --
2097       ----------------
2098
2099       procedure Write_Node
2100         (Stream : not null access Root_Stream_Type'Class;
2101          Node   : Node_Access)
2102       is
2103       begin
2104          Element_Type'Write (Stream, Node.Element);
2105       end Write_Node;
2106
2107    --  Start of processing for Write
2108
2109    begin
2110       Write (Stream, Container.Tree);
2111    end Write;
2112
2113    procedure Write
2114      (Stream : not null access Root_Stream_Type'Class;
2115       Item   : Cursor)
2116    is
2117    begin
2118       raise Program_Error with "attempt to stream set cursor";
2119    end Write;
2120
2121    procedure Write
2122      (Stream : not null access Root_Stream_Type'Class;
2123       Item   : Constant_Reference_Type)
2124    is
2125    begin
2126       raise Program_Error with "attempt to stream reference";
2127    end Write;
2128
2129 end Ada.Containers.Ordered_Sets;