gcc/ada/a-ciorse.adb

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