gcc/ada/a-ciormu.adb

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