gcc/ada/a-coormu.adb

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