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