gcc/ada/a-cborse.adb

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