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