gcc/ada/a-cforse.adb

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