gcc/ada/a-coormu.adb

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