gcc/ada/a-coormu.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 _ M U L T I S E T S      --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with Ada.Unchecked_Deallocation;
  31
  32 with Ada.Containers.Red_Black_Trees.Generic_Operations;
  33 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
  34
  35 with Ada.Containers.Red_Black_Trees.Generic_Keys;
  36 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
  37
  38 with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
  39 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
  40
  41 with System; use type System.Address;
  42
  43 package body Ada.Containers.Ordered_Multisets is
  44
  45    -----------------------------
  46    -- Node Access Subprograms --
  47    -----------------------------
  48
  49    --  These subprograms provide a functional interface to access fields
  50    --  of a node, and a procedural interface for modifying these values.
  51
  52    function Color (Node : Node_Access) return Color_Type;
  53    pragma Inline (Color);
  54
  55    function Left (Node : Node_Access) return Node_Access;
  56    pragma Inline (Left);
  57
  58    function Parent (Node : Node_Access) return Node_Access;
  59    pragma Inline (Parent);
  60
  61    function Right (Node : Node_Access) return Node_Access;
  62    pragma Inline (Right);
  63
  64    procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
  65    pragma Inline (Set_Parent);
  66
  67    procedure Set_Left (Node : Node_Access; Left : Node_Access);
  68    pragma Inline (Set_Left);
  69
  70    procedure Set_Right (Node : Node_Access; Right : Node_Access);
  71    pragma Inline (Set_Right);
  72
  73    procedure Set_Color (Node : Node_Access; Color : Color_Type);
  74    pragma Inline (Set_Color);
  75
  76    -----------------------
  77    -- Local Subprograms --
  78    -----------------------
  79
  80    function Copy_Node (Source : Node_Access) return Node_Access;
  81    pragma Inline (Copy_Node);
  82
  83    procedure Free (X : in out Node_Access);
  84
  85    procedure Insert_Sans_Hint
  86      (Tree     : in out Tree_Type;
  87       New_Item : Element_Type;
  88       Node     : out Node_Access);
  89
  90    procedure Insert_With_Hint
  91      (Dst_Tree : in out Tree_Type;
  92       Dst_Hint : Node_Access;
  93       Src_Node : Node_Access;
  94       Dst_Node : out Node_Access);
  95
  96    function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
  97    pragma Inline (Is_Equal_Node_Node);
  98
  99    function Is_Greater_Element_Node
 100      (Left  : Element_Type;
 101       Right : Node_Access) return Boolean;
 102    pragma Inline (Is_Greater_Element_Node);
 103
 104    function Is_Less_Element_Node
 105      (Left  : Element_Type;
 106       Right : Node_Access) return Boolean;
 107    pragma Inline (Is_Less_Element_Node);
 108
 109    function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
 110    pragma Inline (Is_Less_Node_Node);
 111
 112    procedure Replace_Element
 113      (Tree : in out Tree_Type;
 114       Node : Node_Access;
 115       Item : Element_Type);
 116
 117    --------------------------
 118    -- Local Instantiations --
 119    --------------------------
 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       if Left.Node = null then
 158          raise Constraint_Error with "Left cursor equals No_Element";
 159       end if;
 160
 161       if Right.Node = null then
 162          raise Constraint_Error with "Right cursor equals No_Element";
 163       end if;
 164
 165       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 166                      "bad Left cursor in ""<""");
 167
 168       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 169                      "bad Right cursor in ""<""");
 170
 171       return Left.Node.Element < Right.Node.Element;
 172    end "<";
 173
 174    function "<" (Left : Cursor; Right : Element_Type)
 175       return Boolean is
 176    begin
 177       if Left.Node = null then
 178          raise Constraint_Error with "Left cursor equals No_Element";
 179       end if;
 180
 181       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 182                      "bad Left cursor in ""<""");
 183
 184       return Left.Node.Element < Right;
 185    end "<";
 186
 187    function "<" (Left : Element_Type; Right : Cursor)
 188       return Boolean is
 189    begin
 190       if Right.Node = null then
 191          raise Constraint_Error with "Right cursor equals No_Element";
 192       end if;
 193
 194       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 195                      "bad Right cursor in ""<""");
 196
 197       return Left < Right.Node.Element;
 198    end "<";
 199
 200    ---------
 201    -- "=" --
 202    ---------
 203
 204    function "=" (Left, Right : Set) return Boolean is
 205    begin
 206       return Is_Equal (Left.Tree, Right.Tree);
 207    end "=";
 208
 209    ---------
 210    -- ">" --
 211    ---------
 212
 213    function ">" (Left, Right : Cursor) return Boolean is
 214    begin
 215       if Left.Node = null then
 216          raise Constraint_Error with "Left cursor equals No_Element";
 217       end if;
 218
 219       if Right.Node = null then
 220          raise Constraint_Error with "Right cursor equals No_Element";
 221       end if;
 222
 223       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 224                      "bad Left cursor in "">""");
 225
 226       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 227                      "bad Right cursor in "">""");
 228
 229       --  L > R same as R < L
 230
 231       return Right.Node.Element < Left.Node.Element;
 232    end ">";
 233
 234    function ">" (Left : Cursor; Right : Element_Type)
 235       return Boolean is
 236    begin
 237       if Left.Node = null then
 238          raise Constraint_Error with "Left cursor equals No_Element";
 239       end if;
 240
 241       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 242                      "bad Left cursor in "">""");
 243
 244       return Right < Left.Node.Element;
 245    end ">";
 246
 247    function ">" (Left : Element_Type; Right : Cursor)
 248       return Boolean is
 249    begin
 250       if Right.Node = null then
 251          raise Constraint_Error with "Right cursor equals No_Element";
 252       end if;
 253
 254       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 255                      "bad Right cursor in "">""");
 256
 257       return Right.Node.Element < Left;
 258    end ">";
 259
 260    ------------
 261    -- Adjust --
 262    ------------
 263
 264    procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree);
 265
 266    procedure Adjust (Container : in out Set) is
 267    begin
 268       Adjust (Container.Tree);
 269    end Adjust;
 270
 271    ------------
 272    -- Assign --
 273    ------------
 274
 275    procedure Assign (Target : in out Set; Source : Set) is
 276    begin
 277       if Target'Address = Source'Address then
 278          return;
 279       end if;
 280
 281       Target.Clear;
 282       Target.Union (Source);
 283    end Assign;
 284
 285    -------------
 286    -- Ceiling --
 287    -------------
 288
 289    function Ceiling (Container : Set; Item : Element_Type) return Cursor is
 290       Node : constant Node_Access :=
 291                Element_Keys.Ceiling (Container.Tree, Item);
 292
 293    begin
 294       if Node = null then
 295          return No_Element;
 296       end if;
 297
 298       return Cursor'(Container'Unrestricted_Access, Node);
 299    end Ceiling;
 300
 301    -----------
 302    -- Clear --
 303    -----------
 304
 305    procedure Clear is
 306       new Tree_Operations.Generic_Clear (Delete_Tree);
 307
 308    procedure Clear (Container : in out Set) is
 309    begin
 310       Clear (Container.Tree);
 311    end Clear;
 312
 313    -----------
 314    -- Color --
 315    -----------
 316
 317    function Color (Node : Node_Access) return Color_Type is
 318    begin
 319       return Node.Color;
 320    end Color;
 321
 322    --------------
 323    -- Contains --
 324    --------------
 325
 326    function Contains (Container : Set; Item : Element_Type) return Boolean is
 327    begin
 328       return Find (Container, Item) /= No_Element;
 329    end Contains;
 330
 331    ----------
 332    -- Copy --
 333    ----------
 334
 335    function Copy (Source : Set) return Set is
 336    begin
 337       return Target : Set do
 338          Target.Assign (Source);
 339       end return;
 340    end Copy;
 341
 342    ---------------
 343    -- Copy_Node --
 344    ---------------
 345
 346    function Copy_Node (Source : Node_Access) return Node_Access is
 347       Target : constant Node_Access :=
 348                  new Node_Type'(Parent  => null,
 349                                 Left    => null,
 350                                 Right   => null,
 351                                 Color   => Source.Color,
 352                                 Element => Source.Element);
 353    begin
 354       return Target;
 355    end Copy_Node;
 356
 357    ------------
 358    -- Delete --
 359    ------------
 360
 361    procedure Delete (Container : in out Set; Item : Element_Type) is
 362       Tree : Tree_Type renames Container.Tree;
 363       Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
 364       Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
 365       X    : Node_Access;
 366
 367    begin
 368       if Node = Done then
 369          raise Constraint_Error with
 370            "attempt to delete element not in set";
 371       end if;
 372
 373       loop
 374          X := Node;
 375          Node := Tree_Operations.Next (Node);
 376          Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 377          Free (X);
 378
 379          exit when Node = Done;
 380       end loop;
 381    end Delete;
 382
 383    procedure Delete (Container : in out Set; Position : in out Cursor) is
 384    begin
 385       if Position.Node = null then
 386          raise Constraint_Error with "Position cursor equals No_Element";
 387       end if;
 388
 389       if Position.Container /= Container'Unrestricted_Access then
 390          raise Program_Error with "Position cursor designates wrong set";
 391       end if;
 392
 393       pragma Assert (Vet (Container.Tree, Position.Node),
 394                      "bad cursor in Delete");
 395
 396       Delete_Node_Sans_Free (Container.Tree, Position.Node);
 397       Free (Position.Node);
 398
 399       Position.Container := null;
 400    end Delete;
 401
 402    ------------------
 403    -- Delete_First --
 404    ------------------
 405
 406    procedure Delete_First (Container : in out Set) is
 407       Tree : Tree_Type renames Container.Tree;
 408       X    : Node_Access := Tree.First;
 409
 410    begin
 411       if X = null then
 412          return;
 413       end if;
 414
 415       Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 416       Free (X);
 417    end Delete_First;
 418
 419    -----------------
 420    -- Delete_Last --
 421    -----------------
 422
 423    procedure Delete_Last (Container : in out Set) is
 424       Tree : Tree_Type renames Container.Tree;
 425       X    : Node_Access := Tree.Last;
 426
 427    begin
 428       if X = null then
 429          return;
 430       end if;
 431
 432       Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 433       Free (X);
 434    end Delete_Last;
 435
 436    ----------------
 437    -- Difference --
 438    ----------------
 439
 440    procedure Difference (Target : in out Set; Source : Set) is
 441    begin
 442       Set_Ops.Difference (Target.Tree, Source.Tree);
 443    end Difference;
 444
 445    function Difference (Left, Right : Set) return Set is
 446       Tree : constant Tree_Type :=
 447                Set_Ops.Difference (Left.Tree, Right.Tree);
 448    begin
 449       return Set'(Controlled with Tree);
 450    end Difference;
 451
 452    -------------
 453    -- Element --
 454    -------------
 455
 456    function Element (Position : Cursor) return Element_Type is
 457    begin
 458       if Position.Node = null then
 459          raise Constraint_Error with "Position cursor equals No_Element";
 460       end if;
 461
 462       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 463                      "bad cursor in Element");
 464
 465       return Position.Node.Element;
 466    end Element;
 467
 468    -------------------------
 469    -- Equivalent_Elements --
 470    -------------------------
 471
 472    function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
 473    begin
 474       if Left < Right
 475         or else Right < Left
 476       then
 477          return False;
 478       else
 479          return True;
 480       end if;
 481    end Equivalent_Elements;
 482
 483    ---------------------
 484    -- Equivalent_Sets --
 485    ---------------------
 486
 487    function Equivalent_Sets (Left, Right : Set) return Boolean is
 488
 489       function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
 490       pragma Inline (Is_Equivalent_Node_Node);
 491
 492       function Is_Equivalent is
 493         new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
 494
 495       -----------------------------
 496       -- Is_Equivalent_Node_Node --
 497       -----------------------------
 498
 499       function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
 500       begin
 501          if L.Element < R.Element then
 502             return False;
 503          elsif R.Element < L.Element then
 504             return False;
 505          else
 506             return True;
 507          end if;
 508       end Is_Equivalent_Node_Node;
 509
 510    --  Start of processing for Equivalent_Sets
 511
 512    begin
 513       return Is_Equivalent (Left.Tree, Right.Tree);
 514    end Equivalent_Sets;
 515
 516    -------------
 517    -- Exclude --
 518    -------------
 519
 520    procedure Exclude (Container : in out Set; Item : Element_Type) is
 521       Tree : Tree_Type renames Container.Tree;
 522       Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
 523       Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
 524       X    : Node_Access;
 525    begin
 526       while Node /= Done loop
 527          X := Node;
 528          Node := Tree_Operations.Next (Node);
 529          Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 530          Free (X);
 531       end loop;
 532    end Exclude;
 533
 534    ----------
 535    -- Find --
 536    ----------
 537
 538    function Find (Container : Set; Item : Element_Type) return Cursor is
 539       Node : constant Node_Access :=
 540                Element_Keys.Find (Container.Tree, Item);
 541
 542    begin
 543       if Node = null then
 544          return No_Element;
 545       end if;
 546
 547       return Cursor'(Container'Unrestricted_Access, Node);
 548    end Find;
 549
 550    -----------
 551    -- First --
 552    -----------
 553
 554    function First (Container : Set) return Cursor is
 555    begin
 556       if Container.Tree.First = null then
 557          return No_Element;
 558       end if;
 559
 560       return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
 561    end First;
 562
 563    -------------------
 564    -- First_Element --
 565    -------------------
 566
 567    function First_Element (Container : Set) return Element_Type is
 568    begin
 569       if Container.Tree.First = null then
 570          raise Constraint_Error with "set is empty";
 571       end if;
 572
 573       return Container.Tree.First.Element;
 574    end First_Element;
 575
 576    -----------
 577    -- Floor --
 578    -----------
 579
 580    function Floor (Container : Set; Item : Element_Type) return Cursor is
 581       Node : constant Node_Access :=
 582                Element_Keys.Floor (Container.Tree, Item);
 583
 584    begin
 585       if Node = null then
 586          return No_Element;
 587       end if;
 588
 589       return Cursor'(Container'Unrestricted_Access, Node);
 590    end Floor;
 591
 592    ----------
 593    -- Free --
 594    ----------
 595
 596    procedure Free (X : in out Node_Access) is
 597       procedure Deallocate is
 598          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 599
 600    begin
 601       if X /= null then
 602          X.Parent := X;
 603          X.Left := X;
 604          X.Right := X;
 605
 606          Deallocate (X);
 607       end if;
 608    end Free;
 609
 610    ------------------
 611    -- Generic_Keys --
 612    ------------------
 613
 614    package body Generic_Keys is
 615
 616       -----------------------
 617       -- Local Subprograms --
 618       -----------------------
 619
 620       function Is_Greater_Key_Node
 621         (Left  : Key_Type;
 622          Right : Node_Access) return Boolean;
 623       pragma Inline (Is_Greater_Key_Node);
 624
 625       function Is_Less_Key_Node
 626         (Left  : Key_Type;
 627          Right : Node_Access) return Boolean;
 628       pragma Inline (Is_Less_Key_Node);
 629
 630       --------------------------
 631       -- Local_Instantiations --
 632       --------------------------
 633
 634       package Key_Keys is
 635          new Red_Black_Trees.Generic_Keys
 636           (Tree_Operations     => Tree_Operations,
 637            Key_Type            => Key_Type,
 638            Is_Less_Key_Node    => Is_Less_Key_Node,
 639            Is_Greater_Key_Node => Is_Greater_Key_Node);
 640
 641       -------------
 642       -- Ceiling --
 643       -------------
 644
 645       function Ceiling (Container : Set; Key : Key_Type) return Cursor is
 646          Node : constant Node_Access :=
 647                   Key_Keys.Ceiling (Container.Tree, Key);
 648
 649       begin
 650          if Node = null then
 651             return No_Element;
 652          end if;
 653
 654          return Cursor'(Container'Unrestricted_Access, Node);
 655       end Ceiling;
 656
 657       --------------
 658       -- Contains --
 659       --------------
 660
 661       function Contains (Container : Set; Key : Key_Type) return Boolean is
 662       begin
 663          return Find (Container, Key) /= No_Element;
 664       end Contains;
 665
 666       ------------
 667       -- Delete --
 668       ------------
 669
 670       procedure Delete (Container : in out Set; Key : Key_Type) is
 671          Tree : Tree_Type renames Container.Tree;
 672          Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
 673          Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
 674          X    : Node_Access;
 675
 676       begin
 677          if Node = Done then
 678             raise Constraint_Error with "attempt to delete key not in set";
 679          end if;
 680
 681          loop
 682             X := Node;
 683             Node := Tree_Operations.Next (Node);
 684             Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 685             Free (X);
 686
 687             exit when Node = Done;
 688          end loop;
 689       end Delete;
 690
 691       -------------
 692       -- Element --
 693       -------------
 694
 695       function Element (Container : Set; Key : Key_Type) return Element_Type is
 696          Node : constant Node_Access :=
 697                   Key_Keys.Find (Container.Tree, Key);
 698       begin
 699          if Node = null then
 700             raise Constraint_Error with "key not in set";
 701          end if;
 702
 703          return Node.Element;
 704       end Element;
 705
 706       ---------------------
 707       -- Equivalent_Keys --
 708       ---------------------
 709
 710       function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
 711       begin
 712          if Left < Right
 713            or else Right < Left
 714          then
 715             return False;
 716          else
 717             return True;
 718          end if;
 719       end Equivalent_Keys;
 720
 721       -------------
 722       -- Exclude --
 723       -------------
 724
 725       procedure Exclude (Container : in out Set; Key : Key_Type) is
 726          Tree : Tree_Type renames Container.Tree;
 727          Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
 728          Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
 729          X    : Node_Access;
 730
 731       begin
 732          while Node /= Done loop
 733             X := Node;
 734             Node := Tree_Operations.Next (Node);
 735             Tree_Operations.Delete_Node_Sans_Free (Tree, X);
 736             Free (X);
 737          end loop;
 738       end Exclude;
 739
 740       ----------
 741       -- Find --
 742       ----------
 743
 744       function Find (Container : Set; Key : Key_Type) return Cursor is
 745          Node : constant Node_Access :=
 746                   Key_Keys.Find (Container.Tree, Key);
 747
 748       begin
 749          if Node = null then
 750             return No_Element;
 751          end if;
 752
 753          return Cursor'(Container'Unrestricted_Access, Node);
 754       end Find;
 755
 756       -----------
 757       -- Floor --
 758       -----------
 759
 760       function Floor (Container : Set; Key : Key_Type) return Cursor is
 761          Node : constant Node_Access :=
 762                   Key_Keys.Floor (Container.Tree, Key);
 763
 764       begin
 765          if Node = null then
 766             return No_Element;
 767          end if;
 768
 769          return Cursor'(Container'Unrestricted_Access, Node);
 770       end Floor;
 771
 772       -------------------------
 773       -- Is_Greater_Key_Node --
 774       -------------------------
 775
 776       function Is_Greater_Key_Node
 777         (Left  : Key_Type;
 778          Right : Node_Access) return Boolean is
 779       begin
 780          return Key (Right.Element) < Left;
 781       end Is_Greater_Key_Node;
 782
 783       ----------------------
 784       -- Is_Less_Key_Node --
 785       ----------------------
 786
 787       function Is_Less_Key_Node
 788         (Left  : Key_Type;
 789          Right : Node_Access) return Boolean is
 790       begin
 791          return Left < Key (Right.Element);
 792       end Is_Less_Key_Node;
 793
 794       -------------
 795       -- Iterate --
 796       -------------
 797
 798       procedure Iterate
 799         (Container : Set;
 800          Key       : Key_Type;
 801          Process   : not null access procedure (Position : Cursor))
 802       is
 803          procedure Process_Node (Node : Node_Access);
 804          pragma Inline (Process_Node);
 805
 806          procedure Local_Iterate is
 807            new Key_Keys.Generic_Iteration (Process_Node);
 808
 809          ------------------
 810          -- Process_Node --
 811          ------------------
 812
 813          procedure Process_Node (Node : Node_Access) is
 814          begin
 815             Process (Cursor'(Container'Unrestricted_Access, Node));
 816          end Process_Node;
 817
 818          T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
 819          B : Natural renames T.Busy;
 820
 821       --  Start of processing for Iterate
 822
 823       begin
 824          B := B + 1;
 825
 826          begin
 827             Local_Iterate (T, Key);
 828          exception
 829             when others =>
 830                B := B - 1;
 831                raise;
 832          end;
 833
 834          B := B - 1;
 835       end Iterate;
 836
 837       ---------
 838       -- Key --
 839       ---------
 840
 841       function Key (Position : Cursor) return Key_Type is
 842       begin
 843          if Position.Node = null then
 844             raise Constraint_Error with
 845               "Position cursor equals No_Element";
 846          end if;
 847
 848          pragma Assert (Vet (Position.Container.Tree, Position.Node),
 849                         "bad cursor in Key");
 850
 851          return Key (Position.Node.Element);
 852       end Key;
 853
 854       ---------------------
 855       -- Reverse_Iterate --
 856       ---------------------
 857
 858       procedure Reverse_Iterate
 859         (Container : Set;
 860          Key       : Key_Type;
 861          Process   : not null access procedure (Position : Cursor))
 862       is
 863          procedure Process_Node (Node : Node_Access);
 864          pragma Inline (Process_Node);
 865
 866          procedure Local_Reverse_Iterate is
 867            new Key_Keys.Generic_Reverse_Iteration (Process_Node);
 868
 869          ------------------
 870          -- Process_Node --
 871          ------------------
 872
 873          procedure Process_Node (Node : Node_Access) is
 874          begin
 875             Process (Cursor'(Container'Unrestricted_Access, Node));
 876          end Process_Node;
 877
 878          T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
 879          B : Natural renames T.Busy;
 880
 881       --  Start of processing for Reverse_Iterate
 882
 883       begin
 884          B := B + 1;
 885
 886          begin
 887             Local_Reverse_Iterate (T, Key);
 888          exception
 889             when others =>
 890                B := B - 1;
 891                raise;
 892          end;
 893
 894          B := B - 1;
 895       end Reverse_Iterate;
 896
 897       --------------------
 898       -- Update_Element --
 899       --------------------
 900
 901       procedure Update_Element
 902         (Container : in out Set;
 903          Position  : Cursor;
 904          Process   : not null access procedure (Element : in out Element_Type))
 905       is
 906          Tree : Tree_Type renames Container.Tree;
 907          Node : constant Node_Access := Position.Node;
 908
 909       begin
 910          if Node = null then
 911             raise Constraint_Error with
 912               "Position cursor equals No_Element";
 913          end if;
 914
 915          if Position.Container /= Container'Unrestricted_Access then
 916             raise Program_Error with
 917               "Position cursor designates wrong set";
 918          end if;
 919
 920          pragma Assert (Vet (Tree, Node),
 921                         "bad cursor in Update_Element");
 922
 923          declare
 924             E : Element_Type renames Node.Element;
 925             K : constant Key_Type := Key (E);
 926
 927             B : Natural renames Tree.Busy;
 928             L : Natural renames Tree.Lock;
 929
 930          begin
 931             B := B + 1;
 932             L := L + 1;
 933
 934             begin
 935                Process (E);
 936             exception
 937                when others =>
 938                   L := L - 1;
 939                   B := B - 1;
 940                   raise;
 941             end;
 942
 943             L := L - 1;
 944             B := B - 1;
 945
 946             if Equivalent_Keys (Left => K, Right => Key (E)) then
 947                return;
 948             end if;
 949          end;
 950
 951          --  Delete_Node checks busy-bit
 952
 953          Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
 954
 955          Insert_New_Item : declare
 956             function New_Node return Node_Access;
 957             pragma Inline (New_Node);
 958
 959             procedure Insert_Post is
 960                new Element_Keys.Generic_Insert_Post (New_Node);
 961
 962             procedure Unconditional_Insert is
 963                new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
 964
 965             --------------
 966             -- New_Node --
 967             --------------
 968
 969             function New_Node return Node_Access is
 970             begin
 971                Node.Color := Red_Black_Trees.Red;
 972                Node.Parent := null;
 973                Node.Left := null;
 974                Node.Right := null;
 975
 976                return Node;
 977             end New_Node;
 978
 979             Result : Node_Access;
 980
 981          --  Start of processing for Insert_New_Item
 982
 983          begin
 984             Unconditional_Insert
 985               (Tree => Tree,
 986                Key  => Node.Element,
 987                Node => Result);
 988
 989             pragma Assert (Result = Node);
 990          end Insert_New_Item;
 991       end Update_Element;
 992
 993    end Generic_Keys;
 994
 995    -----------------
 996    -- Has_Element --
 997    -----------------
 998
 999    function Has_Element (Position : Cursor) return Boolean is
1000    begin
1001       return Position /= No_Element;
1002    end Has_Element;
1003
1004    ------------
1005    -- Insert --
1006    ------------
1007
1008    procedure Insert (Container : in out Set; New_Item : Element_Type) is
1009       Position : Cursor;
1010       pragma Unreferenced (Position);
1011    begin
1012       Insert (Container, New_Item, Position);
1013    end Insert;
1014
1015    procedure Insert
1016      (Container : in out Set;
1017       New_Item  : Element_Type;
1018       Position  : out Cursor)
1019    is
1020    begin
1021       Insert_Sans_Hint (Container.Tree, New_Item, Position.Node);
1022       Position.Container := Container'Unrestricted_Access;
1023    end Insert;
1024
1025    ----------------------
1026    -- Insert_Sans_Hint --
1027    ----------------------
1028
1029    procedure Insert_Sans_Hint
1030      (Tree     : in out Tree_Type;
1031       New_Item : Element_Type;
1032       Node     : out Node_Access)
1033    is
1034       function New_Node return Node_Access;
1035       pragma Inline (New_Node);
1036
1037       procedure Insert_Post is
1038         new Element_Keys.Generic_Insert_Post (New_Node);
1039
1040       procedure Unconditional_Insert is
1041         new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1042
1043       --------------
1044       -- New_Node --
1045       --------------
1046
1047       function New_Node return Node_Access is
1048          Node : constant Node_Access :=
1049                   new Node_Type'(Parent  => null,
1050                                  Left    => null,
1051                                  Right   => null,
1052                                  Color   => Red_Black_Trees.Red,
1053                                  Element => New_Item);
1054       begin
1055          return Node;
1056       end New_Node;
1057
1058    --  Start of processing for Insert_Sans_Hint
1059
1060    begin
1061       Unconditional_Insert (Tree, New_Item, Node);
1062    end Insert_Sans_Hint;
1063
1064    ----------------------
1065    -- Insert_With_Hint --
1066    ----------------------
1067
1068    procedure Insert_With_Hint
1069      (Dst_Tree : in out Tree_Type;
1070       Dst_Hint : Node_Access;
1071       Src_Node : Node_Access;
1072       Dst_Node : out Node_Access)
1073    is
1074       function New_Node return Node_Access;
1075       pragma Inline (New_Node);
1076
1077       procedure Insert_Post is
1078         new Element_Keys.Generic_Insert_Post (New_Node);
1079
1080       procedure Insert_Sans_Hint is
1081         new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1082
1083       procedure Local_Insert_With_Hint is
1084         new Element_Keys.Generic_Unconditional_Insert_With_Hint
1085           (Insert_Post,
1086            Insert_Sans_Hint);
1087
1088       --------------
1089       -- New_Node --
1090       --------------
1091
1092       function New_Node return Node_Access is
1093          Node : constant Node_Access :=
1094                   new Node_Type'(Parent  => null,
1095                                  Left    => null,
1096                                  Right   => null,
1097                                  Color   => Red,
1098                                  Element => Src_Node.Element);
1099       begin
1100          return Node;
1101       end New_Node;
1102
1103    --  Start of processing for Insert_With_Hint
1104
1105    begin
1106       Local_Insert_With_Hint
1107         (Dst_Tree,
1108          Dst_Hint,
1109          Src_Node.Element,
1110          Dst_Node);
1111    end Insert_With_Hint;
1112
1113    ------------------
1114    -- Intersection --
1115    ------------------
1116
1117    procedure Intersection (Target : in out Set; Source : Set) is
1118    begin
1119       Set_Ops.Intersection (Target.Tree, Source.Tree);
1120    end Intersection;
1121
1122    function Intersection (Left, Right : Set) return Set is
1123       Tree : constant Tree_Type :=
1124                Set_Ops.Intersection (Left.Tree, Right.Tree);
1125    begin
1126       return Set'(Controlled with Tree);
1127    end Intersection;
1128
1129    --------------
1130    -- Is_Empty --
1131    --------------
1132
1133    function Is_Empty (Container : Set) return Boolean is
1134    begin
1135       return Container.Tree.Length = 0;
1136    end Is_Empty;
1137
1138    ------------------------
1139    -- Is_Equal_Node_Node --
1140    ------------------------
1141
1142    function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1143    begin
1144       return L.Element = R.Element;
1145    end Is_Equal_Node_Node;
1146
1147    -----------------------------
1148    -- Is_Greater_Element_Node --
1149    -----------------------------
1150
1151    function Is_Greater_Element_Node
1152      (Left  : Element_Type;
1153       Right : Node_Access) return Boolean
1154    is
1155    begin
1156       --  e > node same as node < e
1157
1158       return Right.Element < Left;
1159    end Is_Greater_Element_Node;
1160
1161    --------------------------
1162    -- Is_Less_Element_Node --
1163    --------------------------
1164
1165    function Is_Less_Element_Node
1166      (Left  : Element_Type;
1167       Right : Node_Access) return Boolean
1168    is
1169    begin
1170       return Left < Right.Element;
1171    end Is_Less_Element_Node;
1172
1173    -----------------------
1174    -- Is_Less_Node_Node --
1175    -----------------------
1176
1177    function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1178    begin
1179       return L.Element < R.Element;
1180    end Is_Less_Node_Node;
1181
1182    ---------------
1183    -- Is_Subset --
1184    ---------------
1185
1186    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1187    begin
1188       return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1189    end Is_Subset;
1190
1191    -------------
1192    -- Iterate --
1193    -------------
1194
1195    procedure Iterate
1196      (Container : Set;
1197       Process   : not null access procedure (Position : Cursor))
1198    is
1199       procedure Process_Node (Node : Node_Access);
1200       pragma Inline (Process_Node);
1201
1202       procedure Local_Iterate is
1203         new Tree_Operations.Generic_Iteration (Process_Node);
1204
1205       ------------------
1206       -- Process_Node --
1207       ------------------
1208
1209       procedure Process_Node (Node : Node_Access) is
1210       begin
1211          Process (Cursor'(Container'Unrestricted_Access, Node));
1212       end Process_Node;
1213
1214       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1215       B : Natural renames T.Busy;
1216
1217    --  Start of processing for Iterate
1218
1219    begin
1220       B := B + 1;
1221
1222       begin
1223          Local_Iterate (T);
1224       exception
1225          when others =>
1226             B := B - 1;
1227             raise;
1228       end;
1229
1230       B := B - 1;
1231    end Iterate;
1232
1233    procedure Iterate
1234      (Container : Set;
1235       Item      : Element_Type;
1236       Process   : not null access procedure (Position : Cursor))
1237    is
1238       procedure Process_Node (Node : Node_Access);
1239       pragma Inline (Process_Node);
1240
1241       procedure Local_Iterate is
1242         new Element_Keys.Generic_Iteration (Process_Node);
1243
1244       ------------------
1245       -- Process_Node --
1246       ------------------
1247
1248       procedure Process_Node (Node : Node_Access) is
1249       begin
1250          Process (Cursor'(Container'Unrestricted_Access, Node));
1251       end Process_Node;
1252
1253       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1254       B : Natural renames T.Busy;
1255
1256    --  Start of processing for Iterate
1257
1258    begin
1259       B := B + 1;
1260
1261       begin
1262          Local_Iterate (T, Item);
1263       exception
1264          when others =>
1265             B := B - 1;
1266             raise;
1267       end;
1268
1269       B := B - 1;
1270    end Iterate;
1271
1272    ----------
1273    -- Last --
1274    ----------
1275
1276    function Last (Container : Set) return Cursor is
1277    begin
1278       if Container.Tree.Last = null then
1279          return No_Element;
1280       end if;
1281
1282       return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
1283    end Last;
1284
1285    ------------------
1286    -- Last_Element --
1287    ------------------
1288
1289    function Last_Element (Container : Set) return Element_Type is
1290    begin
1291       if Container.Tree.Last = null then
1292          raise Constraint_Error with "set is empty";
1293       end if;
1294
1295       return Container.Tree.Last.Element;
1296    end Last_Element;
1297
1298    ----------
1299    -- Left --
1300    ----------
1301
1302    function Left (Node : Node_Access) return Node_Access is
1303    begin
1304       return Node.Left;
1305    end Left;
1306
1307    ------------
1308    -- Length --
1309    ------------
1310
1311    function Length (Container : Set) return Count_Type is
1312    begin
1313       return Container.Tree.Length;
1314    end Length;
1315
1316    ----------
1317    -- Move --
1318    ----------
1319
1320    procedure Move is
1321       new Tree_Operations.Generic_Move (Clear);
1322
1323    procedure Move (Target : in out Set; Source : in out Set) is
1324    begin
1325       Move (Target => Target.Tree, Source => Source.Tree);
1326    end Move;
1327
1328    ----------
1329    -- Next --
1330    ----------
1331
1332    procedure Next (Position : in out Cursor)
1333    is
1334    begin
1335       Position := Next (Position);
1336    end Next;
1337
1338    function Next (Position : Cursor) return Cursor is
1339    begin
1340       if Position = No_Element then
1341          return No_Element;
1342       end if;
1343
1344       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1345                      "bad cursor in Next");
1346
1347       declare
1348          Node : constant Node_Access :=
1349                   Tree_Operations.Next (Position.Node);
1350       begin
1351          if Node = null then
1352             return No_Element;
1353          end if;
1354
1355          return Cursor'(Position.Container, Node);
1356       end;
1357    end Next;
1358
1359    -------------
1360    -- Overlap --
1361    -------------
1362
1363    function Overlap (Left, Right : Set) return Boolean is
1364    begin
1365       return Set_Ops.Overlap (Left.Tree, Right.Tree);
1366    end Overlap;
1367
1368    ------------
1369    -- Parent --
1370    ------------
1371
1372    function Parent (Node : Node_Access) return Node_Access is
1373    begin
1374       return Node.Parent;
1375    end Parent;
1376
1377    --------------
1378    -- Previous --
1379    --------------
1380
1381    procedure Previous (Position : in out Cursor)
1382    is
1383    begin
1384       Position := Previous (Position);
1385    end Previous;
1386
1387    function Previous (Position : Cursor) return Cursor is
1388    begin
1389       if Position = No_Element then
1390          return No_Element;
1391       end if;
1392
1393       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1394                      "bad cursor in Previous");
1395
1396       declare
1397          Node : constant Node_Access :=
1398                   Tree_Operations.Previous (Position.Node);
1399       begin
1400          if Node = null then
1401             return No_Element;
1402          end if;
1403
1404          return Cursor'(Position.Container, Node);
1405       end;
1406    end Previous;
1407
1408    -------------------
1409    -- Query_Element --
1410    -------------------
1411
1412    procedure Query_Element
1413      (Position : Cursor;
1414       Process  : not null access procedure (Element : Element_Type))
1415    is
1416    begin
1417       if Position.Node = null then
1418          raise Constraint_Error with "Position cursor equals No_Element";
1419       end if;
1420
1421       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1422                      "bad cursor in Query_Element");
1423
1424       declare
1425          T : Tree_Type renames Position.Container.Tree;
1426
1427          B : Natural renames T.Busy;
1428          L : Natural renames T.Lock;
1429
1430       begin
1431          B := B + 1;
1432          L := L + 1;
1433
1434          begin
1435             Process (Position.Node.Element);
1436          exception
1437             when others =>
1438                L := L - 1;
1439                B := B - 1;
1440                raise;
1441          end;
1442
1443          L := L - 1;
1444          B := B - 1;
1445       end;
1446    end Query_Element;
1447
1448    ----------
1449    -- Read --
1450    ----------
1451
1452    procedure Read
1453      (Stream    : not null access Root_Stream_Type'Class;
1454       Container : out Set)
1455    is
1456       function Read_Node
1457         (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1458       pragma Inline (Read_Node);
1459
1460       procedure Read is
1461          new Tree_Operations.Generic_Read (Clear, Read_Node);
1462
1463       ---------------
1464       -- Read_Node --
1465       ---------------
1466
1467       function Read_Node
1468         (Stream : not null access Root_Stream_Type'Class) return Node_Access
1469       is
1470          Node : Node_Access := new Node_Type;
1471       begin
1472          Element_Type'Read (Stream, Node.Element);
1473          return Node;
1474       exception
1475          when others =>
1476             Free (Node);  --  Note that Free deallocates elem too
1477             raise;
1478       end Read_Node;
1479
1480    --  Start of processing for Read
1481
1482    begin
1483       Read (Stream, Container.Tree);
1484    end Read;
1485
1486    procedure Read
1487      (Stream : not null access Root_Stream_Type'Class;
1488       Item   : out Cursor)
1489    is
1490    begin
1491       raise Program_Error with "attempt to stream set cursor";
1492    end Read;
1493
1494    ---------------------
1495    -- Replace_Element --
1496    ---------------------
1497
1498    procedure Replace_Element
1499      (Tree : in out Tree_Type;
1500       Node : Node_Access;
1501       Item : Element_Type)
1502    is
1503    begin
1504       if Item < Node.Element
1505         or else Node.Element < Item
1506       then
1507          null;
1508       else
1509          if Tree.Lock > 0 then
1510             raise Program_Error with
1511               "attempt to tamper with elements (set is locked)";
1512          end if;
1513
1514          Node.Element := Item;
1515          return;
1516       end if;
1517
1518       Tree_Operations.Delete_Node_Sans_Free (Tree, Node);  -- Checks busy-bit
1519
1520       Insert_New_Item : declare
1521          function New_Node return Node_Access;
1522          pragma Inline (New_Node);
1523
1524          procedure Insert_Post is
1525             new Element_Keys.Generic_Insert_Post (New_Node);
1526
1527          procedure Unconditional_Insert is
1528             new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1529
1530          --------------
1531          -- New_Node --
1532          --------------
1533
1534          function New_Node return Node_Access is
1535          begin
1536             Node.Element := Item;
1537             Node.Color := Red_Black_Trees.Red;
1538             Node.Parent := null;
1539             Node.Left := null;
1540             Node.Right := null;
1541
1542             return Node;
1543          end New_Node;
1544
1545          Result : Node_Access;
1546
1547       --  Start of processing for Insert_New_Item
1548
1549       begin
1550          Unconditional_Insert
1551            (Tree => Tree,
1552             Key  => Item,
1553             Node => Result);
1554
1555          pragma Assert (Result = Node);
1556       end Insert_New_Item;
1557    end Replace_Element;
1558
1559    procedure Replace_Element
1560      (Container : in out Set;
1561       Position  : Cursor;
1562       New_Item  : Element_Type)
1563    is
1564    begin
1565       if Position.Node = null then
1566          raise Constraint_Error with
1567            "Position cursor equals No_Element";
1568       end if;
1569
1570       if Position.Container /= Container'Unrestricted_Access then
1571          raise Program_Error with
1572            "Position cursor designates wrong set";
1573       end if;
1574
1575       pragma Assert (Vet (Container.Tree, Position.Node),
1576                      "bad cursor in Replace_Element");
1577
1578       Replace_Element (Container.Tree, Position.Node, New_Item);
1579    end Replace_Element;
1580
1581    ---------------------
1582    -- Reverse_Iterate --
1583    ---------------------
1584
1585    procedure Reverse_Iterate
1586      (Container : Set;
1587       Process   : not null access procedure (Position : Cursor))
1588    is
1589       procedure Process_Node (Node : Node_Access);
1590       pragma Inline (Process_Node);
1591
1592       procedure Local_Reverse_Iterate is
1593         new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1594
1595       ------------------
1596       -- Process_Node --
1597       ------------------
1598
1599       procedure Process_Node (Node : Node_Access) is
1600       begin
1601          Process (Cursor'(Container'Unrestricted_Access, Node));
1602       end Process_Node;
1603
1604       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1605       B : Natural renames T.Busy;
1606
1607    --  Start of processing for Reverse_Iterate
1608
1609    begin
1610       B := B + 1;
1611
1612       begin
1613          Local_Reverse_Iterate (T);
1614       exception
1615          when others =>
1616             B := B - 1;
1617             raise;
1618       end;
1619
1620       B := B - 1;
1621    end Reverse_Iterate;
1622
1623    procedure Reverse_Iterate
1624      (Container : Set;
1625       Item      : Element_Type;
1626       Process   : not null access procedure (Position : Cursor))
1627    is
1628       procedure Process_Node (Node : Node_Access);
1629       pragma Inline (Process_Node);
1630
1631       procedure Local_Reverse_Iterate is
1632          new Element_Keys.Generic_Reverse_Iteration (Process_Node);
1633
1634       ------------------
1635       -- Process_Node --
1636       ------------------
1637
1638       procedure Process_Node (Node : Node_Access) is
1639       begin
1640          Process (Cursor'(Container'Unrestricted_Access, Node));
1641       end Process_Node;
1642
1643       T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1644       B : Natural renames T.Busy;
1645
1646    --  Start of processing for Reverse_Iterate
1647
1648    begin
1649       B := B + 1;
1650
1651       begin
1652          Local_Reverse_Iterate (T, Item);
1653       exception
1654          when others =>
1655             B := B - 1;
1656             raise;
1657       end;
1658
1659       B := B - 1;
1660    end Reverse_Iterate;
1661
1662    -----------
1663    -- Right --
1664    -----------
1665
1666    function Right (Node : Node_Access) return Node_Access is
1667    begin
1668       return Node.Right;
1669    end Right;
1670
1671    ---------------
1672    -- Set_Color --
1673    ---------------
1674
1675    procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1676    begin
1677       Node.Color := Color;
1678    end Set_Color;
1679
1680    --------------
1681    -- Set_Left --
1682    --------------
1683
1684    procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1685    begin
1686       Node.Left := Left;
1687    end Set_Left;
1688
1689    ----------------
1690    -- Set_Parent --
1691    ----------------
1692
1693    procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1694    begin
1695       Node.Parent := Parent;
1696    end Set_Parent;
1697
1698    ---------------
1699    -- Set_Right --
1700    ---------------
1701
1702    procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1703    begin
1704       Node.Right := Right;
1705    end Set_Right;
1706
1707    --------------------------
1708    -- Symmetric_Difference --
1709    --------------------------
1710
1711    procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1712    begin
1713       Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1714    end Symmetric_Difference;
1715
1716    function Symmetric_Difference (Left, Right : Set) return Set is
1717       Tree : constant Tree_Type :=
1718                Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1719    begin
1720       return Set'(Controlled with Tree);
1721    end Symmetric_Difference;
1722
1723    ------------
1724    -- To_Set --
1725    ------------
1726
1727    function To_Set (New_Item : Element_Type) return Set is
1728       Tree : Tree_Type;
1729       Node : Node_Access;
1730       pragma Unreferenced (Node);
1731    begin
1732       Insert_Sans_Hint (Tree, New_Item, Node);
1733       return Set'(Controlled with Tree);
1734    end To_Set;
1735
1736    -----------
1737    -- Union --
1738    -----------
1739
1740    procedure Union (Target : in out Set; Source : Set) is
1741    begin
1742       Set_Ops.Union (Target.Tree, Source.Tree);
1743    end Union;
1744
1745    function Union (Left, Right : Set) return Set is
1746       Tree : constant Tree_Type :=
1747                Set_Ops.Union (Left.Tree, Right.Tree);
1748    begin
1749       return Set'(Controlled with Tree);
1750    end Union;
1751
1752    -----------
1753    -- Write --
1754    -----------
1755
1756    procedure Write
1757      (Stream    : not null access Root_Stream_Type'Class;
1758       Container : Set)
1759    is
1760       procedure Write_Node
1761         (Stream : not null access Root_Stream_Type'Class;
1762          Node   : Node_Access);
1763       pragma Inline (Write_Node);
1764
1765       procedure Write is
1766          new Tree_Operations.Generic_Write (Write_Node);
1767
1768       ----------------
1769       -- Write_Node --
1770       ----------------
1771
1772       procedure Write_Node
1773         (Stream : not null access Root_Stream_Type'Class;
1774          Node   : Node_Access)
1775       is
1776       begin
1777          Element_Type'Write (Stream, Node.Element);
1778       end Write_Node;
1779
1780    --  Start of processing for Write
1781
1782    begin
1783       Write (Stream, Container.Tree);
1784    end Write;
1785
1786    procedure Write
1787      (Stream : not null access Root_Stream_Type'Class;
1788       Item   : Cursor)
1789    is
1790    begin
1791       raise Program_Error with "attempt to stream set cursor";
1792    end Write;
1793
1794 end Ada.Containers.Ordered_Multisets;