gcc/ada/a-coorse.adb

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