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-2013, 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       -- Ceiling --
 695       -------------
 696
 697       function Ceiling (Container : Set; Key : Key_Type) return Cursor is
 698          Node : constant Node_Access := Key_Keys.Ceiling (Container.Tree, Key);
 699       begin
 700          return (if Node = null then No_Element
 701                  else Cursor'(Container'Unrestricted_Access, Node));
 702       end Ceiling;
 703
 704       ------------------------
 705       -- Constant_Reference --
 706       ------------------------
 707
 708       function Constant_Reference
 709         (Container : aliased Set;
 710          Key       : Key_Type) return Constant_Reference_Type
 711       is
 712          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 713
 714       begin
 715          if Node = null then
 716             raise Constraint_Error with "key not in set";
 717          end if;
 718
 719          declare
 720             Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree;
 721             B : Natural renames Tree.Busy;
 722             L : Natural renames Tree.Lock;
 723          begin
 724             return R : constant Constant_Reference_Type :=
 725               (Element => Node.Element'Access,
 726                Control => (Controlled with Container'Unrestricted_Access))
 727             do
 728                B := B + 1;
 729                L := L + 1;
 730             end return;
 731          end;
 732       end Constant_Reference;
 733
 734       --------------
 735       -- Contains --
 736       --------------
 737
 738       function Contains (Container : Set; Key : Key_Type) return Boolean is
 739       begin
 740          return Find (Container, Key) /= No_Element;
 741       end Contains;
 742
 743       ------------
 744       -- Delete --
 745       ------------
 746
 747       procedure Delete (Container : in out Set; Key : Key_Type) is
 748          X : Node_Access := Key_Keys.Find (Container.Tree, Key);
 749
 750       begin
 751          if X = null then
 752             raise Constraint_Error with "attempt to delete key not in set";
 753          end if;
 754
 755          Delete_Node_Sans_Free (Container.Tree, X);
 756          Free (X);
 757       end Delete;
 758
 759       -------------
 760       -- Element --
 761       -------------
 762
 763       function Element (Container : Set; Key : Key_Type) return Element_Type is
 764          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 765
 766       begin
 767          if Node = null then
 768             raise Constraint_Error with "key not in set";
 769          end if;
 770
 771          return Node.Element;
 772       end Element;
 773
 774       ---------------------
 775       -- Equivalent_Keys --
 776       ---------------------
 777
 778       function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
 779       begin
 780          return (if Left < Right or else Right < Left then False else True);
 781       end Equivalent_Keys;
 782
 783       -------------
 784       -- Exclude --
 785       -------------
 786
 787       procedure Exclude (Container : in out Set; Key : Key_Type) is
 788          X : Node_Access := Key_Keys.Find (Container.Tree, Key);
 789       begin
 790          if X /= null then
 791             Delete_Node_Sans_Free (Container.Tree, X);
 792             Free (X);
 793          end if;
 794       end Exclude;
 795
 796       ----------
 797       -- Find --
 798       ----------
 799
 800       function Find (Container : Set; Key : Key_Type) return Cursor is
 801          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 802       begin
 803          return (if Node = null then No_Element
 804                  else Cursor'(Container'Unrestricted_Access, Node));
 805       end Find;
 806
 807       -----------
 808       -- Floor --
 809       -----------
 810
 811       function Floor (Container : Set; Key : Key_Type) return Cursor is
 812          Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
 813       begin
 814          return (if Node = null then No_Element
 815                  else Cursor'(Container'Unrestricted_Access, Node));
 816       end Floor;
 817
 818       -------------------------
 819       -- Is_Greater_Key_Node --
 820       -------------------------
 821
 822       function Is_Greater_Key_Node
 823         (Left  : Key_Type;
 824          Right : Node_Access) return Boolean
 825       is
 826       begin
 827          return Key (Right.Element) < Left;
 828       end Is_Greater_Key_Node;
 829
 830       ----------------------
 831       -- Is_Less_Key_Node --
 832       ----------------------
 833
 834       function Is_Less_Key_Node
 835         (Left  : Key_Type;
 836          Right : Node_Access) return Boolean
 837       is
 838       begin
 839          return Left < Key (Right.Element);
 840       end Is_Less_Key_Node;
 841
 842       ---------
 843       -- Key --
 844       ---------
 845
 846       function Key (Position : Cursor) return Key_Type is
 847       begin
 848          if Position.Node = null then
 849             raise Constraint_Error with
 850               "Position cursor equals No_Element";
 851          end if;
 852
 853          pragma Assert (Vet (Position.Container.Tree, Position.Node),
 854                         "bad cursor in Key");
 855
 856          return Key (Position.Node.Element);
 857       end Key;
 858
 859       ----------
 860       -- Read --
 861       ----------
 862
 863       procedure Read
 864         (Stream : not null access Root_Stream_Type'Class;
 865          Item   : out Reference_Type)
 866       is
 867       begin
 868          raise Program_Error with "attempt to stream reference";
 869       end Read;
 870
 871       ------------------------------
 872       -- Reference_Preserving_Key --
 873       ------------------------------
 874
 875       function Reference_Preserving_Key
 876         (Container : aliased in out Set;
 877          Position  : Cursor) return Reference_Type
 878       is
 879       begin
 880          if Position.Container = null then
 881             raise Constraint_Error with "Position cursor has no element";
 882          end if;
 883
 884          if Position.Container /= Container'Unrestricted_Access then
 885             raise Program_Error with
 886               "Position cursor designates wrong container";
 887          end if;
 888
 889          pragma Assert
 890            (Vet (Container.Tree, Position.Node),
 891             "bad cursor in function Reference_Preserving_Key");
 892
 893          --  Some form of finalization will be required in order to actually
 894          --  check that the key-part of the element designated by Position has
 895          --  not changed.  ???
 896
 897          return (Element => Position.Node.Element'Access);
 898       end Reference_Preserving_Key;
 899
 900       function Reference_Preserving_Key
 901         (Container : aliased in out Set;
 902          Key       : Key_Type) return Reference_Type
 903       is
 904          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 905
 906       begin
 907          if Node = null then
 908             raise Constraint_Error with "key not in set";
 909          end if;
 910
 911          --  Some form of finalization will be required in order to actually
 912          --  check that the key-part of the element designated by Position has
 913          --  not changed.  ???
 914
 915          return (Element => Node.Element'Access);
 916       end Reference_Preserving_Key;
 917
 918       -------------
 919       -- Replace --
 920       -------------
 921
 922       procedure Replace
 923         (Container : in out Set;
 924          Key       : Key_Type;
 925          New_Item  : Element_Type)
 926       is
 927          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 928
 929       begin
 930          if Node = null then
 931             raise Constraint_Error with
 932               "attempt to replace key not in set";
 933          end if;
 934
 935          Replace_Element (Container.Tree, Node, New_Item);
 936       end Replace;
 937
 938       -----------------------------------
 939       -- Update_Element_Preserving_Key --
 940       -----------------------------------
 941
 942       procedure Update_Element_Preserving_Key
 943         (Container : in out Set;
 944          Position  : Cursor;
 945          Process   : not null access procedure (Element : in out Element_Type))
 946       is
 947          Tree : Tree_Type renames Container.Tree;
 948
 949       begin
 950          if Position.Node = null then
 951             raise Constraint_Error with
 952               "Position cursor equals No_Element";
 953          end if;
 954
 955          if Position.Container /= Container'Unrestricted_Access then
 956             raise Program_Error with
 957               "Position cursor designates wrong set";
 958          end if;
 959
 960          pragma Assert (Vet (Container.Tree, Position.Node),
 961                         "bad cursor in Update_Element_Preserving_Key");
 962
 963          declare
 964             E : Element_Type renames Position.Node.Element;
 965             K : constant Key_Type := Key (E);
 966
 967             B : Natural renames Tree.Busy;
 968             L : Natural renames Tree.Lock;
 969
 970             Eq : Boolean;
 971
 972          begin
 973             B := B + 1;
 974             L := L + 1;
 975
 976             begin
 977                Process (E);
 978                Eq := Equivalent_Keys (K, Key (E));
 979             exception
 980                when others =>
 981                   L := L - 1;
 982                   B := B - 1;
 983                   raise;
 984             end;
 985
 986             L := L - 1;
 987             B := B - 1;
 988
 989             if Eq then
 990                return;
 991             end if;
 992          end;
 993
 994          declare
 995             X : Node_Access := Position.Node;
 996          begin
 997             Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 998             Free (X);
 999          end;
1000
1001          raise Program_Error with "key was modified";
1002       end Update_Element_Preserving_Key;
1003
1004       -----------
1005       -- Write --
1006       -----------
1007
1008       procedure Write
1009         (Stream : not null access Root_Stream_Type'Class;
1010          Item   : Reference_Type)
1011       is
1012       begin
1013          raise Program_Error with "attempt to stream reference";
1014       end Write;
1015
1016    end Generic_Keys;
1017
1018    -----------------
1019    -- Has_Element --
1020    -----------------
1021
1022    function Has_Element (Position : Cursor) return Boolean is
1023    begin
1024       return Position /= No_Element;
1025    end Has_Element;
1026
1027    -------------
1028    -- Include --
1029    -------------
1030
1031    procedure Include (Container : in out Set; New_Item : Element_Type) is
1032       Position : Cursor;
1033       Inserted : Boolean;
1034
1035    begin
1036       Insert (Container, New_Item, Position, Inserted);
1037
1038       if not Inserted then
1039          if Container.Tree.Lock > 0 then
1040             raise Program_Error with
1041               "attempt to tamper with elements (set is locked)";
1042          end if;
1043
1044          Position.Node.Element := New_Item;
1045       end if;
1046    end Include;
1047
1048    ------------
1049    -- Insert --
1050    ------------
1051
1052    procedure Insert
1053      (Container : in out Set;
1054       New_Item  : Element_Type;
1055       Position  : out Cursor;
1056       Inserted  : out Boolean)
1057    is
1058    begin
1059       Insert_Sans_Hint
1060         (Container.Tree,
1061          New_Item,
1062          Position.Node,
1063          Inserted);
1064
1065       Position.Container := Container'Unrestricted_Access;
1066    end Insert;
1067
1068    procedure Insert
1069      (Container : in out Set;
1070       New_Item  : Element_Type)
1071    is
1072       Position : Cursor;
1073       pragma Unreferenced (Position);
1074
1075       Inserted : Boolean;
1076
1077    begin
1078       Insert (Container, New_Item, Position, Inserted);
1079
1080       if not Inserted then
1081          raise Constraint_Error with
1082            "attempt to insert element already in set";
1083       end if;
1084    end Insert;
1085
1086    ----------------------
1087    -- Insert_Sans_Hint --
1088    ----------------------
1089
1090    procedure Insert_Sans_Hint
1091      (Tree     : in out Tree_Type;
1092       New_Item : Element_Type;
1093       Node     : out Node_Access;
1094       Inserted : out Boolean)
1095    is
1096       function New_Node return Node_Access;
1097       pragma Inline (New_Node);
1098
1099       procedure Insert_Post is
1100         new Element_Keys.Generic_Insert_Post (New_Node);
1101
1102       procedure Conditional_Insert_Sans_Hint is
1103         new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1104
1105       --------------
1106       -- New_Node --
1107       --------------
1108
1109       function New_Node return Node_Access is
1110       begin
1111          return new Node_Type'(Parent  => null,
1112                                Left    => null,
1113                                Right   => null,
1114                                Color   => Red_Black_Trees.Red,
1115                                Element => New_Item);
1116       end New_Node;
1117
1118    --  Start of processing for Insert_Sans_Hint
1119
1120    begin
1121       Conditional_Insert_Sans_Hint
1122         (Tree,
1123          New_Item,
1124          Node,
1125          Inserted);
1126    end Insert_Sans_Hint;
1127
1128    ----------------------
1129    -- Insert_With_Hint --
1130    ----------------------
1131
1132    procedure Insert_With_Hint
1133      (Dst_Tree : in out Tree_Type;
1134       Dst_Hint : Node_Access;
1135       Src_Node : Node_Access;
1136       Dst_Node : out Node_Access)
1137    is
1138       Success : Boolean;
1139       pragma Unreferenced (Success);
1140
1141       function New_Node return Node_Access;
1142       pragma Inline (New_Node);
1143
1144       procedure Insert_Post is
1145         new Element_Keys.Generic_Insert_Post (New_Node);
1146
1147       procedure Insert_Sans_Hint is
1148         new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1149
1150       procedure Local_Insert_With_Hint is
1151         new Element_Keys.Generic_Conditional_Insert_With_Hint
1152           (Insert_Post,
1153            Insert_Sans_Hint);
1154
1155       --------------
1156       -- New_Node --
1157       --------------
1158
1159       function New_Node return Node_Access is
1160          Node : constant Node_Access :=
1161            new Node_Type'(Parent  => null,
1162                           Left    => null,
1163                           Right   => null,
1164                           Color   => Red,
1165                           Element => Src_Node.Element);
1166       begin
1167          return Node;
1168       end New_Node;
1169
1170    --  Start of processing for Insert_With_Hint
1171
1172    begin
1173       Local_Insert_With_Hint
1174         (Dst_Tree,
1175          Dst_Hint,
1176          Src_Node.Element,
1177          Dst_Node,
1178          Success);
1179    end Insert_With_Hint;
1180
1181    ------------------
1182    -- Intersection --
1183    ------------------
1184
1185    procedure Intersection (Target : in out Set; Source : Set) is
1186    begin
1187       Set_Ops.Intersection (Target.Tree, Source.Tree);
1188    end Intersection;
1189
1190    function Intersection (Left, Right : Set) return Set is
1191       Tree : constant Tree_Type :=
1192         Set_Ops.Intersection (Left.Tree, Right.Tree);
1193    begin
1194       return Set'(Controlled with Tree);
1195    end Intersection;
1196
1197    --------------
1198    -- Is_Empty --
1199    --------------
1200
1201    function Is_Empty (Container : Set) return Boolean is
1202    begin
1203       return Container.Tree.Length = 0;
1204    end Is_Empty;
1205
1206    ------------------------
1207    -- Is_Equal_Node_Node --
1208    ------------------------
1209
1210    function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1211    begin
1212       return L.Element = R.Element;
1213    end Is_Equal_Node_Node;
1214
1215    -----------------------------
1216    -- Is_Greater_Element_Node --
1217    -----------------------------
1218
1219    function Is_Greater_Element_Node
1220      (Left  : Element_Type;
1221       Right : Node_Access) return Boolean
1222    is
1223    begin
1224       --  Compute e > node same as node < e
1225
1226       return Right.Element < Left;
1227    end Is_Greater_Element_Node;
1228
1229    --------------------------
1230    -- Is_Less_Element_Node --
1231    --------------------------
1232
1233    function Is_Less_Element_Node
1234      (Left  : Element_Type;
1235       Right : Node_Access) return Boolean
1236    is
1237    begin
1238       return Left < Right.Element;
1239    end Is_Less_Element_Node;
1240
1241    -----------------------
1242    -- Is_Less_Node_Node --
1243    -----------------------
1244
1245    function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1246    begin
1247       return L.Element < R.Element;
1248    end Is_Less_Node_Node;
1249
1250    ---------------
1251    -- Is_Subset --
1252    ---------------
1253
1254    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1255    begin
1256       return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1257    end Is_Subset;
1258
1259    -------------
1260    -- Iterate --
1261    -------------
1262
1263    procedure Iterate
1264      (Container : Set;
1265       Process   : not null access procedure (Position : Cursor))
1266    is
1267       procedure Process_Node (Node : Node_Access);
1268       pragma Inline (Process_Node);
1269
1270       procedure Local_Iterate is
1271         new Tree_Operations.Generic_Iteration (Process_Node);
1272
1273       ------------------
1274       -- Process_Node --
1275       ------------------
1276
1277       procedure Process_Node (Node : Node_Access) is
1278       begin
1279          Process (Cursor'(Container'Unrestricted_Access, Node));
1280       end Process_Node;
1281
1282       T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
1283       B : Natural renames T.Busy;
1284
1285    --  Start of processing for Iterate
1286
1287    begin
1288       B := B + 1;
1289
1290       begin
1291          Local_Iterate (T);
1292       exception
1293          when others =>
1294             B := B - 1;
1295             raise;
1296       end;
1297
1298       B := B - 1;
1299    end Iterate;
1300
1301    function Iterate (Container : Set)
1302      return Set_Iterator_Interfaces.Reversible_Iterator'Class
1303    is
1304       B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
1305
1306    begin
1307       --  The value of the Node component influences the behavior of the First
1308       --  and Last selector functions of the iterator object. When the Node
1309       --  component is null (as is the case here), this means the iterator
1310       --  object was constructed without a start expression. This is a complete
1311       --  iterator, meaning that the iteration starts from the (logical)
1312       --  beginning of the sequence of items.
1313
1314       --  Note: For a forward iterator, Container.First is the beginning, and
1315       --  for a reverse iterator, Container.Last is the beginning.
1316
1317       B := B + 1;
1318
1319       return It : constant Iterator :=
1320         Iterator'(Limited_Controlled with
1321                     Container => Container'Unrestricted_Access,
1322                     Node      => null);
1323    end Iterate;
1324
1325    function Iterate (Container : Set; Start : Cursor)
1326      return Set_Iterator_Interfaces.Reversible_Iterator'Class
1327    is
1328       B  : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
1329
1330    begin
1331       --  It was formerly the case that when Start = No_Element, the partial
1332       --  iterator was defined to behave the same as for a complete iterator,
1333       --  and iterate over the entire sequence of items. However, those
1334       --  semantics were unintuitive and arguably error-prone (it is too easy
1335       --  to accidentally create an endless loop), and so they were changed,
1336       --  per the ARG meeting in Denver on 2011/11. However, there was no
1337       --  consensus about what positive meaning this corner case should have,
1338       --  and so it was decided to simply raise an exception. This does imply,
1339       --  however, that it is not possible to use a partial iterator to specify
1340       --  an empty sequence of items.
1341
1342       if Start = No_Element then
1343          raise Constraint_Error with
1344            "Start position for iterator equals No_Element";
1345       end if;
1346
1347       if Start.Container /= Container'Unrestricted_Access then
1348          raise Program_Error with
1349            "Start cursor of Iterate designates wrong set";
1350       end if;
1351
1352       pragma Assert (Vet (Container.Tree, Start.Node),
1353                      "Start cursor of Iterate is bad");
1354
1355       --  The value of the Node component influences the behavior of the First
1356       --  and Last selector functions of the iterator object. When the Node
1357       --  component is non-null (as is the case here), it means that this is a
1358       --  partial iteration, over a subset of the complete sequence of
1359       --  items. The iterator object was constructed with a start expression,
1360       --  indicating the position from which the iteration begins. Note that
1361       --  the start position has the same value irrespective of whether this is
1362       --  a forward or reverse iteration.
1363
1364       B := B + 1;
1365
1366       return It : constant Iterator :=
1367         Iterator'(Limited_Controlled with
1368                     Container => Container'Unrestricted_Access,
1369                     Node      => Start.Node);
1370    end Iterate;
1371
1372    ----------
1373    -- Last --
1374    ----------
1375
1376    function Last (Container : Set) return Cursor is
1377    begin
1378       return
1379         (if Container.Tree.Last = null then No_Element
1380          else Cursor'(Container'Unrestricted_Access, Container.Tree.Last));
1381    end Last;
1382
1383    function Last (Object : Iterator) return Cursor is
1384    begin
1385       --  The value of the iterator object's Node component influences the
1386       --  behavior of the Last (and First) selector function.
1387
1388       --  When the Node component is null, this means the iterator object was
1389       --  constructed without a start expression, in which case the (reverse)
1390       --  iteration starts from the (logical) beginning of the entire sequence
1391       --  (corresponding to Container.Last, for a reverse iterator).
1392
1393       --  Otherwise, this is iteration over a partial sequence of items. When
1394       --  the Node component is non-null, the iterator object was constructed
1395       --  with a start expression, that specifies the position from which the
1396       --  (reverse) partial iteration begins.
1397
1398       if Object.Node = null then
1399          return Object.Container.Last;
1400       else
1401          return Cursor'(Object.Container, Object.Node);
1402       end if;
1403    end Last;
1404
1405    ------------------
1406    -- Last_Element --
1407    ------------------
1408
1409    function Last_Element (Container : Set) return Element_Type is
1410    begin
1411       if Container.Tree.Last = null then
1412          raise Constraint_Error with "set is empty";
1413       else
1414          return Container.Tree.Last.Element;
1415       end if;
1416    end Last_Element;
1417
1418    ----------
1419    -- Left --
1420    ----------
1421
1422    function Left (Node : Node_Access) return Node_Access is
1423    begin
1424       return Node.Left;
1425    end Left;
1426
1427    ------------
1428    -- Length --
1429    ------------
1430
1431    function Length (Container : Set) return Count_Type is
1432    begin
1433       return Container.Tree.Length;
1434    end Length;
1435
1436    ----------
1437    -- Move --
1438    ----------
1439
1440    procedure Move is new Tree_Operations.Generic_Move (Clear);
1441
1442    procedure Move (Target : in out Set; Source : in out Set) is
1443    begin
1444       Move (Target => Target.Tree, Source => Source.Tree);
1445    end Move;
1446
1447    ----------
1448    -- Next --
1449    ----------
1450
1451    function Next (Position : Cursor) return Cursor is
1452    begin
1453       if Position = No_Element then
1454          return No_Element;
1455       end if;
1456
1457       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1458                      "bad cursor in Next");
1459
1460       declare
1461          Node : constant Node_Access :=
1462            Tree_Operations.Next (Position.Node);
1463       begin
1464          return (if Node = null then No_Element
1465                  else Cursor'(Position.Container, Node));
1466       end;
1467    end Next;
1468
1469    procedure Next (Position : in out Cursor) is
1470    begin
1471       Position := Next (Position);
1472    end Next;
1473
1474    function Next (Object : Iterator; Position : Cursor) return Cursor is
1475    begin
1476       if Position.Container = null then
1477          return No_Element;
1478       end if;
1479
1480       if Position.Container /= Object.Container then
1481          raise Program_Error with
1482            "Position cursor of Next designates wrong set";
1483       end if;
1484
1485       return Next (Position);
1486    end Next;
1487
1488    -------------
1489    -- Overlap --
1490    -------------
1491
1492    function Overlap (Left, Right : Set) return Boolean is
1493    begin
1494       return Set_Ops.Overlap (Left.Tree, Right.Tree);
1495    end Overlap;
1496
1497    ------------
1498    -- Parent --
1499    ------------
1500
1501    function Parent (Node : Node_Access) return Node_Access is
1502    begin
1503       return Node.Parent;
1504    end Parent;
1505
1506    --------------
1507    -- Previous --
1508    --------------
1509
1510    function Previous (Position : Cursor) return Cursor is
1511    begin
1512       if Position = No_Element then
1513          return No_Element;
1514       end if;
1515
1516       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1517                      "bad cursor in Previous");
1518
1519       declare
1520          Node : constant Node_Access :=
1521            Tree_Operations.Previous (Position.Node);
1522       begin
1523          return (if Node = null then No_Element
1524                  else Cursor'(Position.Container, Node));
1525       end;
1526    end Previous;
1527
1528    procedure Previous (Position : in out Cursor) is
1529    begin
1530       Position := Previous (Position);
1531    end Previous;
1532
1533    function Previous (Object : Iterator; Position : Cursor) return Cursor is
1534    begin
1535       if Position.Container = null then
1536          return No_Element;
1537       end if;
1538
1539       if Position.Container /= Object.Container then
1540          raise Program_Error with
1541            "Position cursor of Previous designates wrong set";
1542       end if;
1543
1544       return Previous (Position);
1545    end Previous;
1546
1547    -------------------
1548    -- Query_Element --
1549    -------------------
1550
1551    procedure Query_Element
1552      (Position : Cursor;
1553       Process  : not null access procedure (Element : Element_Type))
1554    is
1555    begin
1556       if Position.Node = null then
1557          raise Constraint_Error with "Position cursor equals No_Element";
1558       end if;
1559
1560       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1561                      "bad cursor in Query_Element");
1562
1563       declare
1564          T : Tree_Type renames Position.Container.Tree;
1565
1566          B : Natural renames T.Busy;
1567          L : Natural renames T.Lock;
1568
1569       begin
1570          B := B + 1;
1571          L := L + 1;
1572
1573          begin
1574             Process (Position.Node.Element);
1575          exception
1576             when others =>
1577                L := L - 1;
1578                B := B - 1;
1579                raise;
1580          end;
1581
1582          L := L - 1;
1583          B := B - 1;
1584       end;
1585    end Query_Element;
1586
1587    ----------
1588    -- Read --
1589    ----------
1590
1591    procedure Read
1592      (Stream    : not null access Root_Stream_Type'Class;
1593       Container : out Set)
1594    is
1595       function Read_Node
1596         (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1597       pragma Inline (Read_Node);
1598
1599       procedure Read is
1600          new Tree_Operations.Generic_Read (Clear, Read_Node);
1601
1602       ---------------
1603       -- Read_Node --
1604       ---------------
1605
1606       function Read_Node
1607         (Stream : not null access Root_Stream_Type'Class) return Node_Access
1608       is
1609          Node : Node_Access := new Node_Type;
1610       begin
1611          Element_Type'Read (Stream, Node.Element);
1612          return Node;
1613       exception
1614          when others =>
1615             Free (Node);
1616             raise;
1617       end Read_Node;
1618
1619    --  Start of processing for Read
1620
1621    begin
1622       Read (Stream, Container.Tree);
1623    end Read;
1624
1625    procedure Read
1626      (Stream : not null access Root_Stream_Type'Class;
1627       Item   : out Cursor)
1628    is
1629    begin
1630       raise Program_Error with "attempt to stream set cursor";
1631    end Read;
1632
1633    procedure Read
1634      (Stream : not null access Root_Stream_Type'Class;
1635       Item   : out Constant_Reference_Type)
1636    is
1637    begin
1638       raise Program_Error with "attempt to stream reference";
1639    end Read;
1640
1641    -------------
1642    -- Replace --
1643    -------------
1644
1645    procedure Replace (Container : in out Set; New_Item : Element_Type) is
1646       Node : constant Node_Access :=
1647         Element_Keys.Find (Container.Tree, New_Item);
1648
1649    begin
1650       if Node = null then
1651          raise Constraint_Error with
1652            "attempt to replace element not in set";
1653       end if;
1654
1655       if Container.Tree.Lock > 0 then
1656          raise Program_Error with
1657            "attempt to tamper with elements (set is locked)";
1658       end if;
1659
1660       Node.Element := New_Item;
1661    end Replace;
1662
1663    ---------------------
1664    -- Replace_Element --
1665    ---------------------
1666
1667    procedure Replace_Element
1668      (Tree : in out Tree_Type;
1669       Node : Node_Access;
1670       Item : Element_Type)
1671    is
1672       pragma Assert (Node /= null);
1673
1674       function New_Node return Node_Access;
1675       pragma Inline (New_Node);
1676
1677       procedure Local_Insert_Post is
1678          new Element_Keys.Generic_Insert_Post (New_Node);
1679
1680       procedure Local_Insert_Sans_Hint is
1681          new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
1682
1683       procedure Local_Insert_With_Hint is
1684          new Element_Keys.Generic_Conditional_Insert_With_Hint
1685         (Local_Insert_Post,
1686          Local_Insert_Sans_Hint);
1687
1688       --------------
1689       -- New_Node --
1690       --------------
1691
1692       function New_Node return Node_Access is
1693       begin
1694          Node.Element := Item;
1695          Node.Color   := Red;
1696          Node.Parent  := null;
1697          Node.Right   := null;
1698          Node.Left    := null;
1699          return Node;
1700       end New_Node;
1701
1702       Hint     : Node_Access;
1703       Result   : Node_Access;
1704       Inserted : Boolean;
1705       Compare  : Boolean;
1706
1707       --  Per AI05-0022, the container implementation is required to detect
1708       --  element tampering by a generic actual subprogram.
1709
1710       B : Natural renames Tree.Busy;
1711       L : Natural renames Tree.Lock;
1712
1713    --  Start of processing for Replace_Element
1714
1715    begin
1716       --  Replace_Element assigns value Item to the element designated by Node,
1717       --  per certain semantic constraints.
1718
1719       --  If Item is equivalent to the element, then element is replaced and
1720       --  there's nothing else to do. This is the easy case.
1721
1722       --  If Item is not equivalent, then the node will (possibly) have to move
1723       --  to some other place in the tree. This is slighly more complicated,
1724       --  because we must ensure that Item is not equivalent to some other
1725       --  element in the tree (in which case, the replacement is not allowed).
1726
1727       --  Determine whether Item is equivalent to element on the specified
1728       --  node.
1729
1730       begin
1731          B := B + 1;
1732          L := L + 1;
1733
1734          Compare := (if Item < Node.Element then False
1735                      elsif Node.Element < Item then False
1736                      else True);
1737
1738          L := L - 1;
1739          B := B - 1;
1740
1741       exception
1742          when others =>
1743             L := L - 1;
1744             B := B - 1;
1745             raise;
1746       end;
1747
1748       if Compare then
1749          --  Item is equivalent to the node's element, so we will not have to
1750          --  move the node.
1751
1752          if Tree.Lock > 0 then
1753             raise Program_Error with
1754               "attempt to tamper with elements (set is locked)";
1755          end if;
1756
1757          Node.Element := Item;
1758          return;
1759       end if;
1760
1761       --  The replacement Item is not equivalent to the element on the
1762       --  specified node, which means that it will need to be re-inserted in a
1763       --  different position in the tree. We must now determine whether Item is
1764       --  equivalent to some other element in the tree (which would prohibit
1765       --  the assignment and hence the move).
1766
1767       --  Ceiling returns the smallest element equivalent or greater than the
1768       --  specified Item; if there is no such element, then it returns null.
1769
1770       Hint := Element_Keys.Ceiling (Tree, Item);
1771
1772       if Hint /= null then
1773          begin
1774             B := B + 1;
1775             L := L + 1;
1776
1777             Compare := Item < Hint.Element;
1778
1779             L := L - 1;
1780             B := B - 1;
1781
1782          exception
1783             when others =>
1784                L := L - 1;
1785                B := B - 1;
1786                raise;
1787          end;
1788
1789          --  Item >= Hint.Element
1790
1791          if not Compare then
1792
1793             --  Ceiling returns an element that is equivalent or greater
1794             --  than Item. If Item is "not less than" the element, then
1795             --  by elimination we know that Item is equivalent to the element.
1796
1797             --  But this means that it is not possible to assign the value of
1798             --  Item to the specified element (on Node), because a different
1799             --  element (on Hint) equivalent to Item already exsits. (Were we
1800             --  to change Node's element value, we would have to move Node, but
1801             --  we would be unable to move the Node, because its new position
1802             --  in the tree is already occupied by an equivalent element.)
1803
1804             raise Program_Error with "attempt to replace existing element";
1805          end if;
1806
1807          --  Item is not equivalent to any other element in the tree, so it is
1808          --  safe to assign the value of Item to Node.Element. This means that
1809          --  the node will have to move to a different position in the tree
1810          --  (because its element will have a different value).
1811
1812          --  The nearest (greater) neighbor of Item is Hint. This will be the
1813          --  insertion position of Node (because its element will have Item as
1814          --  its new value).
1815
1816          --  If Node equals Hint, the relative position of Node does not
1817          --  change. This allows us to perform an optimization: we need not
1818          --  remove Node from the tree and then reinsert it with its new value,
1819          --  because it would only be placed in the exact same position.
1820
1821          if Hint = Node then
1822             if Tree.Lock > 0 then
1823                raise Program_Error with
1824                  "attempt to tamper with elements (set is locked)";
1825             end if;
1826
1827             Node.Element := Item;
1828             return;
1829          end if;
1830       end if;
1831
1832       --  If we get here, it is because Item was greater than all elements in
1833       --  the tree (Hint = null), or because Item was less than some element at
1834       --  a different place in the tree (Item < Hint.Element). In either case,
1835       --  we remove Node from the tree (without actually deallocating it), and
1836       --  then insert Item into the tree, onto the same Node (so no new node is
1837       --  actually allocated).
1838
1839       Tree_Operations.Delete_Node_Sans_Free (Tree, Node);  -- Checks busy-bit
1840
1841       Local_Insert_With_Hint  -- use unconditional insert here instead???
1842         (Tree     => Tree,
1843          Position => Hint,
1844          Key      => Item,
1845          Node     => Result,
1846          Inserted => Inserted);
1847
1848       pragma Assert (Inserted);
1849       pragma Assert (Result = Node);
1850    end Replace_Element;
1851
1852    procedure Replace_Element
1853      (Container : in out Set;
1854       Position  : Cursor;
1855       New_Item  : Element_Type)
1856    is
1857    begin
1858       if Position.Node = null then
1859          raise Constraint_Error with
1860            "Position cursor equals No_Element";
1861       end if;
1862
1863       if Position.Container /= Container'Unrestricted_Access then
1864          raise Program_Error with
1865            "Position cursor designates wrong set";
1866       end if;
1867
1868       pragma Assert (Vet (Container.Tree, Position.Node),
1869                      "bad cursor in Replace_Element");
1870
1871       Replace_Element (Container.Tree, Position.Node, New_Item);
1872    end Replace_Element;
1873
1874    ---------------------
1875    -- Reverse_Iterate --
1876    ---------------------
1877
1878    procedure Reverse_Iterate
1879      (Container : Set;
1880       Process   : not null access procedure (Position : Cursor))
1881    is
1882       procedure Process_Node (Node : Node_Access);
1883       pragma Inline (Process_Node);
1884
1885       procedure Local_Reverse_Iterate is
1886          new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1887
1888       ------------------
1889       -- Process_Node --
1890       ------------------
1891
1892       procedure Process_Node (Node : Node_Access) is
1893       begin
1894          Process (Cursor'(Container'Unrestricted_Access, Node));
1895       end Process_Node;
1896
1897       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1898       B : Natural renames T.Busy;
1899
1900    --  Start of processing for Reverse_Iterate
1901
1902    begin
1903       B := B + 1;
1904
1905       begin
1906          Local_Reverse_Iterate (T);
1907       exception
1908          when others =>
1909             B := B - 1;
1910             raise;
1911       end;
1912
1913       B := B - 1;
1914    end Reverse_Iterate;
1915
1916    -----------
1917    -- Right --
1918    -----------
1919
1920    function Right (Node : Node_Access) return Node_Access is
1921    begin
1922       return Node.Right;
1923    end Right;
1924
1925    ---------------
1926    -- Set_Color --
1927    ---------------
1928
1929    procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1930    begin
1931       Node.Color := Color;
1932    end Set_Color;
1933
1934    --------------
1935    -- Set_Left --
1936    --------------
1937
1938    procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1939    begin
1940       Node.Left := Left;
1941    end Set_Left;
1942
1943    ----------------
1944    -- Set_Parent --
1945    ----------------
1946
1947    procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1948    begin
1949       Node.Parent := Parent;
1950    end Set_Parent;
1951
1952    ---------------
1953    -- Set_Right --
1954    ---------------
1955
1956    procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1957    begin
1958       Node.Right := Right;
1959    end Set_Right;
1960
1961    --------------------------
1962    -- Symmetric_Difference --
1963    --------------------------
1964
1965    procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1966    begin
1967       Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1968    end Symmetric_Difference;
1969
1970    function Symmetric_Difference (Left, Right : Set) return Set is
1971       Tree : constant Tree_Type :=
1972         Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1973    begin
1974       return Set'(Controlled with Tree);
1975    end Symmetric_Difference;
1976
1977    ------------
1978    -- To_Set --
1979    ------------
1980
1981    function To_Set (New_Item : Element_Type) return Set is
1982       Tree     : Tree_Type;
1983       Node     : Node_Access;
1984       Inserted : Boolean;
1985       pragma Unreferenced (Node, Inserted);
1986    begin
1987       Insert_Sans_Hint (Tree, New_Item, Node, Inserted);
1988       return Set'(Controlled with Tree);
1989    end To_Set;
1990
1991    -----------
1992    -- Union --
1993    -----------
1994
1995    procedure Union (Target : in out Set; Source : Set) is
1996    begin
1997       Set_Ops.Union (Target.Tree, Source.Tree);
1998    end Union;
1999
2000    function Union (Left, Right : Set) return Set is
2001       Tree : constant Tree_Type :=
2002         Set_Ops.Union (Left.Tree, Right.Tree);
2003    begin
2004       return Set'(Controlled with Tree);
2005    end Union;
2006
2007    -----------
2008    -- Write --
2009    -----------
2010
2011    procedure Write
2012      (Stream    : not null access Root_Stream_Type'Class;
2013       Container : Set)
2014    is
2015       procedure Write_Node
2016         (Stream : not null access Root_Stream_Type'Class;
2017          Node   : Node_Access);
2018       pragma Inline (Write_Node);
2019
2020       procedure Write is
2021          new Tree_Operations.Generic_Write (Write_Node);
2022
2023       ----------------
2024       -- Write_Node --
2025       ----------------
2026
2027       procedure Write_Node
2028         (Stream : not null access Root_Stream_Type'Class;
2029          Node   : Node_Access)
2030       is
2031       begin
2032          Element_Type'Write (Stream, Node.Element);
2033       end Write_Node;
2034
2035    --  Start of processing for Write
2036
2037    begin
2038       Write (Stream, Container.Tree);
2039    end Write;
2040
2041    procedure Write
2042      (Stream : not null access Root_Stream_Type'Class;
2043       Item   : Cursor)
2044    is
2045    begin
2046       raise Program_Error with "attempt to stream set cursor";
2047    end Write;
2048
2049    procedure Write
2050      (Stream : not null access Root_Stream_Type'Class;
2051       Item   : Constant_Reference_Type)
2052    is
2053    begin
2054       raise Program_Error with "attempt to stream reference";
2055    end Write;
2056
2057 end Ada.Containers.Ordered_Sets;