gcc/ada/a-coorse.adb

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