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_Sets --
 374    ---------------------
 375
 376    function Equivalent_Sets (Left, Right : Set) return Boolean is
 377
 378       function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
 379       pragma Inline (Is_Equivalent_Node_Node);
 380
 381       function Is_Equivalent is
 382          new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
 383
 384       -----------------------------
 385       -- Is_Equivalent_Node_Node --
 386       -----------------------------
 387
 388       function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
 389       begin
 390          if L.Element.all < R.Element.all then
 391             return False;
 392          elsif R.Element.all < L.Element.all then
 393             return False;
 394          else
 395             return True;
 396          end if;
 397       end Is_Equivalent_Node_Node;
 398
 399    --  Start of processing for Equivalent_Sets
 400
 401    begin
 402       return Is_Equivalent (Left.Tree, Right.Tree);
 403    end Equivalent_Sets;
 404
 405    -------------
 406    -- Exclude --
 407    -------------
 408
 409    procedure Exclude (Container : in out Set; Item : Element_Type) is
 410       X : Node_Access :=
 411             Element_Keys.Find (Container.Tree, Item);
 412
 413    begin
 414       if X /= null then
 415          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 416          Free (X);
 417       end if;
 418    end Exclude;
 419
 420    ----------
 421    -- Find --
 422    ----------
 423
 424    function Find (Container : Set; Item : Element_Type) return Cursor is
 425       Node : constant Node_Access :=
 426                Element_Keys.Find (Container.Tree, Item);
 427
 428    begin
 429       if Node = null then
 430          return No_Element;
 431       end if;
 432
 433       return Cursor'(Container'Unrestricted_Access, Node);
 434    end Find;
 435
 436    -----------
 437    -- First --
 438    -----------
 439
 440    function First (Container : Set) return Cursor is
 441    begin
 442       if Container.Tree.First = null then
 443          return No_Element;
 444       end if;
 445
 446       return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
 447    end First;
 448
 449    -------------------
 450    -- First_Element --
 451    -------------------
 452
 453    function First_Element (Container : Set) return Element_Type is
 454    begin
 455       return Container.Tree.First.Element.all;
 456    end First_Element;
 457
 458    -----------
 459    -- Floor --
 460    -----------
 461
 462    function Floor (Container : Set; Item : Element_Type) return Cursor is
 463       Node : constant Node_Access :=
 464                Element_Keys.Floor (Container.Tree, Item);
 465
 466    begin
 467       if Node = null then
 468          return No_Element;
 469       end if;
 470
 471       return Cursor'(Container'Unrestricted_Access, Node);
 472    end Floor;
 473
 474    ----------
 475    -- Free --
 476    ----------
 477
 478    procedure Free (X : in out Node_Access) is
 479
 480       procedure Deallocate is
 481         new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 482
 483    begin
 484       if X = null then
 485          return;
 486       end if;
 487
 488       begin
 489          Free_Element (X.Element);
 490       exception
 491          when others =>
 492             X.Element := null;
 493             Deallocate (X);
 494             raise;
 495       end;
 496
 497       Deallocate (X);
 498    end Free;
 499
 500    ------------------
 501    -- Generic_Keys --
 502    ------------------
 503
 504    package body Generic_Keys is
 505
 506       -----------------------
 507       -- Local Subprograms --
 508       -----------------------
 509
 510       function Is_Greater_Key_Node
 511         (Left  : Key_Type;
 512          Right : Node_Access) return Boolean;
 513       pragma Inline (Is_Greater_Key_Node);
 514
 515       function Is_Less_Key_Node
 516         (Left  : Key_Type;
 517          Right : Node_Access) return Boolean;
 518       pragma Inline (Is_Less_Key_Node);
 519
 520       --------------------------
 521       -- Local Instantiations --
 522       --------------------------
 523
 524       package Key_Keys is
 525         new Red_Black_Trees.Generic_Keys
 526           (Tree_Operations     => Tree_Operations,
 527            Key_Type            => Key_Type,
 528            Is_Less_Key_Node    => Is_Less_Key_Node,
 529            Is_Greater_Key_Node => Is_Greater_Key_Node);
 530
 531       ---------
 532       -- "<" --
 533       ---------
 534
 535       function "<" (Left : Key_Type; Right : Cursor) return Boolean is
 536       begin
 537          return Left < Right.Node.Element.all;
 538       end "<";
 539
 540       function "<" (Left : Cursor; Right : Key_Type) return Boolean is
 541       begin
 542          return Right > Left.Node.Element.all;
 543       end "<";
 544
 545       ---------
 546       -- ">" --
 547       ---------
 548
 549       function ">" (Left : Key_Type; Right : Cursor) return Boolean is
 550       begin
 551          return Left > Right.Node.Element.all;
 552       end ">";
 553
 554       function ">" (Left : Cursor; Right : Key_Type) return Boolean is
 555       begin
 556          return Right < Left.Node.Element.all;
 557       end ">";
 558
 559       -------------
 560       -- Ceiling --
 561       -------------
 562
 563       function Ceiling (Container : Set; Key : Key_Type) return Cursor is
 564          Node : constant Node_Access :=
 565                   Key_Keys.Ceiling (Container.Tree, Key);
 566
 567       begin
 568          if Node = null then
 569             return No_Element;
 570          end if;
 571
 572          return Cursor'(Container'Unrestricted_Access, Node);
 573       end Ceiling;
 574
 575       --------------
 576       -- Contains --
 577       --------------
 578
 579       function Contains (Container : Set; Key : Key_Type) return Boolean is
 580       begin
 581          return Find (Container, Key) /= No_Element;
 582       end Contains;
 583
 584       ------------
 585       -- Delete --
 586       ------------
 587
 588       procedure Delete (Container : in out Set; Key : Key_Type) is
 589          X : Node_Access := Key_Keys.Find (Container.Tree, Key);
 590
 591       begin
 592          if X = null then
 593             raise Constraint_Error;
 594          end if;
 595
 596          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 597          Free (X);
 598       end Delete;
 599
 600       -------------
 601       -- Element --
 602       -------------
 603
 604       function Element (Container : Set; Key : Key_Type) return Element_Type is
 605          Node : constant Node_Access :=
 606                   Key_Keys.Find (Container.Tree, Key);
 607
 608       begin
 609          return Node.Element.all;
 610       end Element;
 611
 612       -------------
 613       -- Exclude --
 614       -------------
 615
 616       procedure Exclude (Container : in out Set; Key : Key_Type) is
 617          X : Node_Access := Key_Keys.Find (Container.Tree, Key);
 618
 619       begin
 620          if X /= null then
 621             Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 622             Free (X);
 623          end if;
 624       end Exclude;
 625
 626       ----------
 627       -- Find --
 628       ----------
 629
 630       function Find (Container : Set; Key : Key_Type) return Cursor is
 631          Node : constant Node_Access :=
 632                   Key_Keys.Find (Container.Tree, Key);
 633
 634       begin
 635          if Node = null then
 636             return No_Element;
 637          end if;
 638
 639          return Cursor'(Container'Unrestricted_Access, Node);
 640       end Find;
 641
 642       -----------
 643       -- Floor --
 644       -----------
 645
 646       function Floor (Container : Set; Key : Key_Type) return Cursor is
 647          Node : constant Node_Access :=
 648                   Key_Keys.Floor (Container.Tree, Key);
 649
 650       begin
 651          if Node = null then
 652             return No_Element;
 653          end if;
 654
 655          return Cursor'(Container'Unrestricted_Access, Node);
 656       end Floor;
 657
 658       -------------------------
 659       -- Is_Greater_Key_Node --
 660       -------------------------
 661
 662       function Is_Greater_Key_Node
 663         (Left  : Key_Type;
 664          Right : Node_Access) return Boolean is
 665       begin
 666          return Left > Right.Element.all;
 667       end Is_Greater_Key_Node;
 668
 669       ----------------------
 670       -- Is_Less_Key_Node --
 671       ----------------------
 672
 673       function Is_Less_Key_Node
 674         (Left  : Key_Type;
 675          Right : Node_Access) return Boolean is
 676       begin
 677          return Left < Right.Element.all;
 678       end Is_Less_Key_Node;
 679
 680       ---------
 681       -- Key --
 682       ---------
 683
 684       function Key (Position : Cursor) return Key_Type is
 685       begin
 686          return Key (Position.Node.Element.all);
 687       end Key;
 688
 689       -------------
 690       -- Replace --
 691       -------------
 692
 693       procedure Replace
 694         (Container : in out Set;
 695          Key       : Key_Type;
 696          New_Item  : Element_Type)
 697       is
 698          Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
 699
 700       begin
 701          if Node = null then
 702             raise Constraint_Error;
 703          end if;
 704
 705          Replace_Element (Container.Tree, Node, New_Item);
 706       end Replace;
 707
 708       -----------------------------------
 709       -- Update_Element_Preserving_Key --
 710       -----------------------------------
 711
 712       procedure Update_Element_Preserving_Key
 713         (Container : in out Set;
 714          Position  : Cursor;
 715          Process   : not null access
 716                         procedure (Element : in out Element_Type))
 717       is
 718          Tree : Tree_Type renames Container.Tree;
 719
 720       begin
 721          if Position.Node = null then
 722             raise Constraint_Error;
 723          end if;
 724
 725          if Position.Container /= Container'Unrestricted_Access then
 726             raise Program_Error;
 727          end if;
 728
 729          declare
 730             E : Element_Type renames Position.Node.Element.all;
 731             K : Key_Type renames Key (E);
 732
 733             B : Natural renames Tree.Busy;
 734             L : Natural renames Tree.Lock;
 735
 736          begin
 737             B := B + 1;
 738             L := L + 1;
 739
 740             begin
 741                Process (E);
 742             exception
 743                when others =>
 744                   L := L - 1;
 745                   B := B - 1;
 746                   raise;
 747             end;
 748
 749             L := L - 1;
 750             B := B - 1;
 751
 752             if K < E
 753               or else K > E
 754             then
 755                null;
 756             else
 757                return;
 758             end if;
 759          end;
 760
 761          declare
 762             X : Node_Access := Position.Node;
 763          begin
 764             Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 765             Free (X);
 766          end;
 767
 768          raise Program_Error;
 769       end Update_Element_Preserving_Key;
 770
 771    end Generic_Keys;
 772
 773    -----------------
 774    -- Has_Element --
 775    -----------------
 776
 777    function Has_Element (Position : Cursor) return Boolean is
 778    begin
 779       return Position /= No_Element;
 780    end Has_Element;
 781
 782    -------------
 783    -- Include --
 784    -------------
 785
 786    procedure Include (Container : in out Set; New_Item  : Element_Type) is
 787       Position : Cursor;
 788       Inserted : Boolean;
 789
 790       X : Element_Access;
 791
 792    begin
 793       Insert (Container, New_Item, Position, Inserted);
 794
 795       if not Inserted then
 796          if Container.Tree.Lock > 0 then
 797             raise Program_Error;
 798          end if;
 799
 800          X := Position.Node.Element;
 801          Position.Node.Element := new Element_Type'(New_Item);
 802          Free_Element (X);
 803       end if;
 804    end Include;
 805
 806    ------------
 807    -- Insert --
 808    ------------
 809
 810    procedure Insert
 811      (Container : in out Set;
 812       New_Item  : Element_Type;
 813       Position  : out Cursor;
 814       Inserted  : out Boolean)
 815    is
 816       function New_Node return Node_Access;
 817       pragma Inline (New_Node);
 818
 819       procedure Insert_Post is
 820         new Element_Keys.Generic_Insert_Post (New_Node);
 821
 822       procedure Insert_Sans_Hint is
 823         new Element_Keys.Generic_Conditional_Insert (Insert_Post);
 824
 825       --------------
 826       -- New_Node --
 827       --------------
 828
 829       function New_Node return Node_Access is
 830          Element : Element_Access := new Element_Type'(New_Item);
 831       begin
 832          return new Node_Type'(Parent  => null,
 833                                Left    => null,
 834                                Right   => null,
 835                                Color   => Red,
 836                                Element => Element);
 837       exception
 838          when others =>
 839             Free_Element (Element);
 840             raise;
 841       end New_Node;
 842
 843    --  Start of processing for Insert
 844
 845    begin
 846       Insert_Sans_Hint
 847         (Container.Tree,
 848          New_Item,
 849          Position.Node,
 850          Inserted);
 851
 852       Position.Container := Container'Unrestricted_Access;
 853    end Insert;
 854
 855    procedure Insert (Container : in out Set; New_Item  : Element_Type) is
 856       Position : Cursor;
 857       Inserted : Boolean;
 858    begin
 859       Insert (Container, New_Item, Position, Inserted);
 860
 861       if not Inserted then
 862          raise Constraint_Error;
 863       end if;
 864    end Insert;
 865
 866    ----------------------
 867    -- Insert_With_Hint --
 868    ----------------------
 869
 870    procedure Insert_With_Hint
 871      (Dst_Tree : in out Tree_Type;
 872       Dst_Hint : Node_Access;
 873       Src_Node : Node_Access;
 874       Dst_Node : out Node_Access)
 875    is
 876       Success  : Boolean;
 877
 878       function New_Node return Node_Access;
 879
 880       procedure Insert_Post is
 881         new Element_Keys.Generic_Insert_Post (New_Node);
 882
 883       procedure Insert_Sans_Hint is
 884         new Element_Keys.Generic_Conditional_Insert (Insert_Post);
 885
 886       procedure Insert_With_Hint is
 887          new Element_Keys.Generic_Conditional_Insert_With_Hint
 888             (Insert_Post,
 889              Insert_Sans_Hint);
 890
 891       --------------
 892       -- New_Node --
 893       --------------
 894
 895       function New_Node return Node_Access is
 896          Element : Element_Access :=
 897                      new Element_Type'(Src_Node.Element.all);
 898          Node    : Node_Access;
 899
 900       begin
 901          begin
 902             Node := new Node_Type;
 903          exception
 904             when others =>
 905                Free_Element (Element);
 906                raise;
 907          end;
 908
 909          Node.Element := Element;
 910          return Node;
 911       end New_Node;
 912
 913    --  Start of processing for Insert_With_Hint
 914
 915    begin
 916       Insert_With_Hint
 917         (Dst_Tree,
 918          Dst_Hint,
 919          Src_Node.Element.all,
 920          Dst_Node,
 921          Success);
 922    end Insert_With_Hint;
 923
 924    ------------------
 925    -- Intersection --
 926    ------------------
 927
 928    procedure Intersection (Target : in out Set; Source : Set) is
 929    begin
 930       Set_Ops.Intersection (Target.Tree, Source.Tree);
 931    end Intersection;
 932
 933    function Intersection (Left, Right : Set) return Set is
 934       Tree : constant Tree_Type :=
 935                Set_Ops.Intersection (Left.Tree, Right.Tree);
 936    begin
 937       return Set'(Controlled with Tree);
 938    end Intersection;
 939
 940    --------------
 941    -- Is_Empty --
 942    --------------
 943
 944    function Is_Empty (Container : Set) return Boolean is
 945    begin
 946       return Container.Tree.Length = 0;
 947    end Is_Empty;
 948
 949    -----------------------------
 950    -- Is_Greater_Element_Node --
 951    -----------------------------
 952
 953    function Is_Greater_Element_Node
 954      (Left  : Element_Type;
 955       Right : Node_Access) return Boolean is
 956    begin
 957       --  e > node same as node < e
 958
 959       return Right.Element.all < Left;
 960    end Is_Greater_Element_Node;
 961
 962    --------------------------
 963    -- Is_Less_Element_Node --
 964    --------------------------
 965
 966    function Is_Less_Element_Node
 967      (Left  : Element_Type;
 968       Right : Node_Access) return Boolean is
 969    begin
 970       return Left < Right.Element.all;
 971    end Is_Less_Element_Node;
 972
 973    -----------------------
 974    -- Is_Less_Node_Node --
 975    -----------------------
 976
 977    function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
 978    begin
 979       return L.Element.all < R.Element.all;
 980    end Is_Less_Node_Node;
 981
 982    ---------------
 983    -- Is_Subset --
 984    ---------------
 985
 986    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
 987    begin
 988       return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
 989    end Is_Subset;
 990
 991    -------------
 992    -- Iterate --
 993    -------------
 994
 995    procedure Iterate
 996      (Container : Set;
 997       Process   : not null access procedure (Position : Cursor))
 998    is
 999       procedure Process_Node (Node : Node_Access);
1000       pragma Inline (Process_Node);
1001
1002       procedure Local_Iterate is
1003         new Tree_Operations.Generic_Iteration (Process_Node);
1004
1005       ------------------
1006       -- Process_Node --
1007       ------------------
1008
1009       procedure Process_Node (Node : Node_Access) is
1010       begin
1011          Process (Cursor'(Container'Unrestricted_Access, Node));
1012       end Process_Node;
1013
1014       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1015       B : Natural renames T.Busy;
1016
1017    --  Start of prccessing for Iterate
1018
1019    begin
1020       B := B + 1;
1021
1022       begin
1023          Local_Iterate (T);
1024       exception
1025          when others =>
1026             B := B - 1;
1027             raise;
1028       end;
1029
1030       B := B - 1;
1031    end Iterate;
1032
1033    ----------
1034    -- Last --
1035    ----------
1036
1037    function Last (Container : Set) return Cursor is
1038    begin
1039       if Container.Tree.Last = null then
1040          return No_Element;
1041       end if;
1042
1043       return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
1044    end Last;
1045
1046    ------------------
1047    -- Last_Element --
1048    ------------------
1049
1050    function Last_Element (Container : Set) return Element_Type is
1051    begin
1052       return Container.Tree.Last.Element.all;
1053    end Last_Element;
1054
1055    ----------
1056    -- Left --
1057    ----------
1058
1059    function Left (Node : Node_Access) return Node_Access is
1060    begin
1061       return Node.Left;
1062    end Left;
1063
1064    ------------
1065    -- Length --
1066    ------------
1067
1068    function Length (Container : Set) return Count_Type is
1069    begin
1070       return Container.Tree.Length;
1071    end Length;
1072
1073    ----------
1074    -- Move --
1075    ----------
1076
1077    procedure Move is
1078       new Tree_Operations.Generic_Move (Clear);
1079
1080    procedure Move (Target : in out Set; Source : in out Set) is
1081    begin
1082       Move (Target => Target.Tree, Source => Source.Tree);
1083    end Move;
1084
1085    ----------
1086    -- Next --
1087    ----------
1088
1089    procedure Next (Position : in out Cursor) is
1090    begin
1091       Position := Next (Position);
1092    end Next;
1093
1094    function Next (Position : Cursor) return Cursor is
1095    begin
1096       if Position = No_Element then
1097          return No_Element;
1098       end if;
1099
1100       declare
1101          Node : constant Node_Access :=
1102                   Tree_Operations.Next (Position.Node);
1103
1104       begin
1105          if Node = null then
1106             return No_Element;
1107          end if;
1108
1109          return Cursor'(Position.Container, Node);
1110       end;
1111    end Next;
1112
1113    -------------
1114    -- Overlap --
1115    -------------
1116
1117    function Overlap (Left, Right : Set) return Boolean is
1118    begin
1119       return Set_Ops.Overlap (Left.Tree, Right.Tree);
1120    end Overlap;
1121
1122    ------------
1123    -- Parent --
1124    ------------
1125
1126    function Parent (Node : Node_Access) return Node_Access is
1127    begin
1128       return Node.Parent;
1129    end Parent;
1130
1131    --------------
1132    -- Previous --
1133    --------------
1134
1135    procedure Previous (Position : in out Cursor) is
1136    begin
1137       Position := Previous (Position);
1138    end Previous;
1139
1140    function Previous (Position : Cursor) return Cursor is
1141    begin
1142       if Position = No_Element then
1143          return No_Element;
1144       end if;
1145
1146       declare
1147          Node : constant Node_Access :=
1148                   Tree_Operations.Previous (Position.Node);
1149
1150       begin
1151          if Node = null then
1152             return No_Element;
1153          end if;
1154
1155          return Cursor'(Position.Container, Node);
1156       end;
1157    end Previous;
1158
1159    -------------------
1160    -- Query_Element --
1161    -------------------
1162
1163    procedure Query_Element
1164      (Position  : Cursor;
1165       Process   : not null access procedure (Element : Element_Type))
1166    is
1167       E : Element_Type renames Position.Node.Element.all;
1168
1169       S : Set renames Position.Container.all;
1170       T : Tree_Type renames S.Tree'Unrestricted_Access.all;
1171
1172       B : Natural renames T.Busy;
1173       L : Natural renames T.Lock;
1174
1175    begin
1176       B := B + 1;
1177       L := L + 1;
1178
1179       begin
1180          Process (E);
1181       exception
1182          when others =>
1183             L := L - 1;
1184             B := B - 1;
1185             raise;
1186       end;
1187
1188       L := L - 1;
1189       B := B - 1;
1190    end Query_Element;
1191
1192    ----------
1193    -- Read --
1194    ----------
1195
1196    procedure Read
1197      (Stream    : access Root_Stream_Type'Class;
1198       Container : out Set)
1199    is
1200       function Read_Node
1201         (Stream : access Root_Stream_Type'Class) return Node_Access;
1202       pragma Inline (Read_Node);
1203
1204       procedure Read is
1205          new Tree_Operations.Generic_Read (Clear, Read_Node);
1206
1207       ---------------
1208       -- Read_Node --
1209       ---------------
1210
1211       function Read_Node
1212         (Stream : access Root_Stream_Type'Class) return Node_Access
1213       is
1214          Node : Node_Access := new Node_Type;
1215
1216       begin
1217          Node.Element := new Element_Type'(Element_Type'Input (Stream));
1218          return Node;
1219
1220       exception
1221          when others =>
1222             Free (Node);  --  Note that Free deallocates elem too
1223             raise;
1224       end Read_Node;
1225
1226    --  Start of processing for Read
1227
1228    begin
1229       Read (Stream, Container.Tree);
1230    end Read;
1231
1232    -------------
1233    -- Replace --
1234    -------------
1235
1236    procedure Replace (Container : in out Set; New_Item : Element_Type) is
1237       Node : constant Node_Access :=
1238                Element_Keys.Find (Container.Tree, New_Item);
1239
1240       X : Element_Access;
1241
1242    begin
1243       if Node = null then
1244          raise Constraint_Error;
1245       end if;
1246
1247       X := Node.Element;
1248       Node.Element := new Element_Type'(New_Item);
1249       Free_Element (X);
1250    end Replace;
1251
1252    ---------------------
1253    -- Replace_Element --
1254    ---------------------
1255
1256    procedure Replace_Element
1257      (Tree : in out Tree_Type;
1258       Node : Node_Access;
1259       Item : Element_Type)
1260    is
1261    begin
1262       if Item < Node.Element.all
1263         or else Node.Element.all < Item
1264       then
1265          null;
1266       else
1267          if Tree.Lock > 0 then
1268             raise Program_Error;
1269          end if;
1270
1271          declare
1272             X : Element_Access := Node.Element;
1273          begin
1274             Node.Element := new Element_Type'(Item);
1275             Free_Element (X);
1276          end;
1277
1278          return;
1279       end if;
1280
1281       Tree_Operations.Delete_Node_Sans_Free (Tree, Node);  -- Checks busy-bit
1282
1283       Insert_New_Item : declare
1284          function New_Node return Node_Access;
1285          pragma Inline (New_Node);
1286
1287          procedure Insert_Post is
1288             new Element_Keys.Generic_Insert_Post (New_Node);
1289
1290          procedure Insert is
1291             new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1292
1293          --------------
1294          -- New_Node --
1295          --------------
1296
1297          function New_Node return Node_Access is
1298          begin
1299             Node.Element := new Element_Type'(Item);  -- OK if fails
1300             return Node;
1301          end New_Node;
1302
1303          Result   : Node_Access;
1304          Inserted : Boolean;
1305
1306          X : Element_Access := Node.Element;
1307
1308       --  Start of processing for Insert_New_Item
1309
1310       begin
1311          Attempt_Insert : begin
1312             Insert
1313               (Tree    => Tree,
1314                Key     => Item,
1315                Node    => Result,
1316                Success => Inserted);  --  TODO: change name of formal param
1317          exception
1318             when others =>
1319                Inserted := False;
1320          end Attempt_Insert;
1321
1322          if Inserted then
1323             pragma Assert (Result = Node);
1324             Free_Element (X);  -- OK if fails
1325             return;
1326          end if;
1327       end Insert_New_Item;
1328
1329       Reinsert_Old_Element : declare
1330          function New_Node return Node_Access;
1331          pragma Inline (New_Node);
1332
1333          procedure Insert_Post is
1334             new Element_Keys.Generic_Insert_Post (New_Node);
1335
1336          procedure Insert is
1337             new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1338
1339          --------------
1340          -- New_Node --
1341          --------------
1342
1343          function New_Node return Node_Access is
1344          begin
1345             return Node;
1346          end New_Node;
1347
1348          Result   : Node_Access;
1349          Inserted : Boolean;
1350
1351       --  Start of processing for Reinsert_Old_Element
1352
1353       begin
1354          Insert
1355            (Tree    => Tree,
1356             Key     => Node.Element.all,
1357             Node    => Result,
1358             Success => Inserted);  --  TODO: change name of formal param
1359       exception
1360          when others =>
1361             null;
1362       end Reinsert_Old_Element;
1363
1364       raise Program_Error;
1365    end Replace_Element;
1366
1367    procedure Replace_Element
1368     (Container : Set;
1369      Position  : Cursor;
1370      By        : Element_Type)
1371    is
1372       Tree : Tree_Type renames Position.Container.Tree'Unrestricted_Access.all;
1373
1374    begin
1375       if Position.Node = null then
1376          raise Constraint_Error;
1377       end if;
1378
1379       if Position.Container /= Container'Unrestricted_Access then
1380          raise Program_Error;
1381       end if;
1382
1383       Replace_Element (Tree, Position.Node, By);
1384    end Replace_Element;
1385
1386    ---------------------
1387    -- Reverse_Iterate --
1388    ---------------------
1389
1390    procedure Reverse_Iterate
1391      (Container : Set;
1392       Process   : not null access procedure (Position : Cursor))
1393    is
1394       procedure Process_Node (Node : Node_Access);
1395       pragma Inline (Process_Node);
1396
1397       procedure Local_Reverse_Iterate is
1398          new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1399
1400       ------------------
1401       -- Process_Node --
1402       ------------------
1403
1404       procedure Process_Node (Node : Node_Access) is
1405       begin
1406          Process (Cursor'(Container'Unrestricted_Access, Node));
1407       end Process_Node;
1408
1409       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1410       B : Natural renames T.Busy;
1411
1412    --  Start of processing for Reverse_Iterate
1413
1414    begin
1415       B := B + 1;
1416
1417       begin
1418          Local_Reverse_Iterate (T);
1419       exception
1420          when others =>
1421             B := B - 1;
1422             raise;
1423       end;
1424
1425       B := B - 1;
1426    end Reverse_Iterate;
1427
1428    -----------
1429    -- Right --
1430    -----------
1431
1432    function Right (Node : Node_Access) return Node_Access is
1433    begin
1434       return Node.Right;
1435    end Right;
1436
1437    ---------------
1438    -- Set_Color --
1439    ---------------
1440
1441    procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1442    begin
1443       Node.Color := Color;
1444    end Set_Color;
1445
1446    --------------
1447    -- Set_Left --
1448    --------------
1449
1450    procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1451    begin
1452       Node.Left := Left;
1453    end Set_Left;
1454
1455    ----------------
1456    -- Set_Parent --
1457    ----------------
1458
1459    procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1460    begin
1461       Node.Parent := Parent;
1462    end Set_Parent;
1463
1464    ---------------
1465    -- Set_Right --
1466    ---------------
1467
1468    procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1469    begin
1470       Node.Right := Right;
1471    end Set_Right;
1472
1473    --------------------------
1474    -- Symmetric_Difference --
1475    --------------------------
1476
1477    procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1478    begin
1479       Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1480    end Symmetric_Difference;
1481
1482    function Symmetric_Difference (Left, Right : Set) return Set is
1483       Tree : constant Tree_Type :=
1484                Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1485    begin
1486       return Set'(Controlled with Tree);
1487    end Symmetric_Difference;
1488
1489    -----------
1490    -- Union --
1491    -----------
1492
1493    procedure Union (Target : in out Set; Source : Set) is
1494    begin
1495       Set_Ops.Union (Target.Tree, Source.Tree);
1496    end Union;
1497
1498    function Union (Left, Right : Set) return Set is
1499       Tree : constant Tree_Type :=
1500                Set_Ops.Union (Left.Tree, Right.Tree);
1501    begin
1502       return Set'(Controlled with Tree);
1503    end Union;
1504
1505    -----------
1506    -- Write --
1507    -----------
1508
1509    procedure Write
1510      (Stream    : access Root_Stream_Type'Class;
1511       Container : Set)
1512    is
1513       procedure Write_Node
1514         (Stream : access Root_Stream_Type'Class;
1515          Node   : Node_Access);
1516       pragma Inline (Write_Node);
1517
1518       procedure Write is
1519          new Tree_Operations.Generic_Write (Write_Node);
1520
1521       ----------------
1522       -- Write_Node --
1523       ----------------
1524
1525       procedure Write_Node
1526         (Stream : access Root_Stream_Type'Class;
1527          Node   : Node_Access)
1528       is
1529       begin
1530          Element_Type'Output (Stream, Node.Element.all);
1531       end Write_Node;
1532
1533    --  Start of processing for Write
1534
1535    begin
1536       Write (Stream, Container.Tree);
1537    end Write;
1538
1539 end Ada.Containers.Indefinite_Ordered_Sets;