gcc/ada/a-coormu.adb

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