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