gcc/ada/a-ciormu.adb

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