gcc/ada/a-ciorse.adb

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