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       declare
 456          N : Tree_Types.Nodes_Type renames Container.Nodes;
 457       begin
 458          return N (Position.Node).Element;
 459       end;
 460    end Element;
 461
 462    -------------------------
 463    -- Equivalent_Elements --
 464    -------------------------
 465
 466    function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
 467    begin
 468       if Left < Right
 469         or else Right < Left
 470       then
 471          return False;
 472       else
 473          return True;
 474       end if;
 475    end Equivalent_Elements;
 476
 477    ---------------------
 478    -- Equivalent_Sets --
 479    ---------------------
 480
 481    function Equivalent_Sets (Left, Right : Set) return Boolean is
 482       function Is_Equivalent_Node_Node
 483         (L, R : Node_Type) return Boolean;
 484       pragma Inline (Is_Equivalent_Node_Node);
 485
 486       function Is_Equivalent is
 487         new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
 488
 489       -----------------------------
 490       -- Is_Equivalent_Node_Node --
 491       -----------------------------
 492
 493       function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is
 494       begin
 495          if L.Element < R.Element then
 496             return False;
 497          elsif R.Element < L.Element then
 498             return False;
 499          else
 500             return True;
 501          end if;
 502       end Is_Equivalent_Node_Node;
 503
 504    --  Start of processing for Equivalent_Sets
 505
 506    begin
 507       return Is_Equivalent (Left, Right);
 508    end Equivalent_Sets;
 509
 510    -------------
 511    -- Exclude --
 512    -------------
 513
 514    procedure Exclude (Container : in out Set; Item : Element_Type) is
 515       X : constant Count_Type := Element_Keys.Find (Container, Item);
 516    begin
 517       if X /= 0 then
 518          Tree_Operations.Delete_Node_Sans_Free (Container, X);
 519          Formal_Ordered_Sets.Free (Container, X);
 520       end if;
 521    end Exclude;
 522
 523    ----------
 524    -- Find --
 525    ----------
 526
 527    function Find (Container : Set; Item : Element_Type) return Cursor is
 528       Node : constant Count_Type := Element_Keys.Find (Container, Item);
 529
 530    begin
 531       if Node = 0 then
 532          return No_Element;
 533       end if;
 534
 535       return (Node => Node);
 536    end Find;
 537
 538    -----------
 539    -- First --
 540    -----------
 541
 542    function First (Container : Set) return Cursor is
 543    begin
 544       if Length (Container) = 0 then
 545          return No_Element;
 546       end if;
 547
 548       return (Node => Container.First);
 549    end First;
 550
 551    -------------------
 552    -- First_Element --
 553    -------------------
 554
 555    function First_Element (Container : Set) return Element_Type is
 556       Fst : constant Count_Type :=  First (Container).Node;
 557    begin
 558       if Fst = 0 then
 559          raise Constraint_Error with "set is empty";
 560       end if;
 561
 562       declare
 563          N : Tree_Types.Nodes_Type renames Container.Nodes;
 564       begin
 565          return N (Fst).Element;
 566       end;
 567    end First_Element;
 568
 569    -----------
 570    -- Floor --
 571    -----------
 572
 573    function Floor (Container : Set; Item : Element_Type) return Cursor is
 574    begin
 575       declare
 576          Node : constant Count_Type := Element_Keys.Floor (Container, Item);
 577
 578       begin
 579          if Node = 0 then
 580             return No_Element;
 581          end if;
 582
 583          return (Node => Node);
 584       end;
 585    end Floor;
 586
 587    ----------
 588    -- Free --
 589    ----------
 590
 591    procedure Free (Tree : in out Set; X : Count_Type) is
 592    begin
 593       Tree.Nodes (X).Has_Element := False;
 594       Tree_Operations.Free (Tree, X);
 595    end Free;
 596
 597    ----------------------
 598    -- Generic_Allocate --
 599    ----------------------
 600
 601    procedure Generic_Allocate
 602      (Tree : in out Tree_Types.Tree_Type'Class;
 603       Node : out Count_Type)
 604    is
 605       procedure Allocate is
 606         new Tree_Operations.Generic_Allocate (Set_Element);
 607    begin
 608       Allocate (Tree, Node);
 609       Tree.Nodes (Node).Has_Element := True;
 610    end Generic_Allocate;
 611
 612    ------------------
 613    -- Generic_Keys --
 614    ------------------
 615
 616    package body Generic_Keys is
 617
 618       -----------------------
 619       -- Local Subprograms --
 620       -----------------------
 621
 622       function Is_Greater_Key_Node
 623         (Left  : Key_Type;
 624          Right : Node_Type) return Boolean;
 625       pragma Inline (Is_Greater_Key_Node);
 626
 627       function Is_Less_Key_Node
 628         (Left  : Key_Type;
 629          Right : Node_Type) return Boolean;
 630       pragma Inline (Is_Less_Key_Node);
 631
 632       --------------------------
 633       -- Local Instantiations --
 634       --------------------------
 635
 636       package Key_Keys is
 637         new Red_Black_Trees.Generic_Bounded_Keys
 638           (Tree_Operations     => Tree_Operations,
 639            Key_Type            => Key_Type,
 640            Is_Less_Key_Node    => Is_Less_Key_Node,
 641            Is_Greater_Key_Node => Is_Greater_Key_Node);
 642
 643       -------------
 644       -- Ceiling --
 645       -------------
 646
 647       function Ceiling (Container : Set; Key : Key_Type) return Cursor is
 648          Node : constant Count_Type := Key_Keys.Ceiling (Container, Key);
 649
 650       begin
 651          if Node = 0 then
 652             return No_Element;
 653          end if;
 654
 655          return (Node => Node);
 656       end Ceiling;
 657
 658       --------------
 659       -- Contains --
 660       --------------
 661
 662       function Contains (Container : Set; Key : Key_Type) return Boolean is
 663       begin
 664          return Find (Container, Key) /= No_Element;
 665       end Contains;
 666
 667       ------------
 668       -- Delete --
 669       ------------
 670
 671       procedure Delete (Container : in out Set; Key : Key_Type) is
 672          X : constant Count_Type := Key_Keys.Find (Container, Key);
 673
 674       begin
 675          if X = 0 then
 676             raise Constraint_Error with "attempt to delete key not in set";
 677          end if;
 678
 679          Delete_Node_Sans_Free (Container, X);
 680          Formal_Ordered_Sets.Free (Container, X);
 681       end Delete;
 682
 683       -------------
 684       -- Element --
 685       -------------
 686
 687       function Element (Container : Set; Key : Key_Type) return Element_Type is
 688          Node : constant Count_Type := Key_Keys.Find (Container, Key);
 689
 690       begin
 691          if Node = 0 then
 692             raise Constraint_Error with "key not in set";
 693          end if;
 694
 695          declare
 696             N : Tree_Types.Nodes_Type renames Container.Nodes;
 697          begin
 698             return N (Node).Element;
 699          end;
 700       end Element;
 701
 702       ---------------------
 703       -- Equivalent_Keys --
 704       ---------------------
 705
 706       function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
 707       begin
 708          if Left < Right
 709            or else Right < Left
 710          then
 711             return False;
 712          else
 713             return True;
 714          end if;
 715       end Equivalent_Keys;
 716
 717       -------------
 718       -- Exclude --
 719       -------------
 720
 721       procedure Exclude (Container : in out Set; Key : Key_Type) is
 722          X : constant Count_Type := Key_Keys.Find (Container, Key);
 723       begin
 724          if X /= 0 then
 725             Delete_Node_Sans_Free (Container, X);
 726             Formal_Ordered_Sets.Free (Container, X);
 727          end if;
 728       end Exclude;
 729
 730       ----------
 731       -- Find --
 732       ----------
 733
 734       function Find (Container : Set; Key : Key_Type) return Cursor is
 735          Node : constant Count_Type := Key_Keys.Find (Container, Key);
 736       begin
 737          return (if Node = 0 then No_Element else (Node => Node));
 738       end Find;
 739
 740       -----------
 741       -- Floor --
 742       -----------
 743
 744       function Floor (Container : Set; Key : Key_Type) return Cursor is
 745          Node : constant Count_Type := Key_Keys.Floor (Container, Key);
 746       begin
 747          return (if Node = 0 then No_Element else (Node => Node));
 748       end Floor;
 749
 750       -------------------------
 751       -- Is_Greater_Key_Node --
 752       -------------------------
 753
 754       function Is_Greater_Key_Node
 755         (Left  : Key_Type;
 756          Right : Node_Type) return Boolean
 757       is
 758       begin
 759          return Key (Right.Element) < Left;
 760       end Is_Greater_Key_Node;
 761
 762       ----------------------
 763       -- Is_Less_Key_Node --
 764       ----------------------
 765
 766       function Is_Less_Key_Node
 767         (Left  : Key_Type;
 768          Right : Node_Type) return Boolean
 769       is
 770       begin
 771          return Left < Key (Right.Element);
 772       end Is_Less_Key_Node;
 773
 774       ---------
 775       -- Key --
 776       ---------
 777
 778       function Key (Container : Set; Position : Cursor) return Key_Type is
 779       begin
 780          if not Has_Element (Container, Position) then
 781             raise Constraint_Error with
 782               "Position cursor has no element";
 783          end if;
 784
 785          pragma Assert (Vet (Container, Position.Node),
 786                         "bad cursor in Key");
 787
 788          declare
 789             N : Tree_Types.Nodes_Type renames Container.Nodes;
 790          begin
 791             return Key (N (Position.Node).Element);
 792          end;
 793       end Key;
 794
 795       -------------
 796       -- Replace --
 797       -------------
 798
 799       procedure Replace
 800         (Container : in out Set;
 801          Key       : Key_Type;
 802          New_Item  : Element_Type)
 803       is
 804          Node : constant Count_Type := Key_Keys.Find (Container, Key);
 805       begin
 806          if not Has_Element (Container, (Node => Node)) then
 807             raise Constraint_Error with
 808               "attempt to replace key not in set";
 809          else
 810             Replace_Element (Container, Node, New_Item);
 811          end if;
 812       end Replace;
 813
 814       -----------------------------------
 815       -- Update_Element_Preserving_Key --
 816       -----------------------------------
 817
 818       procedure Update_Element_Preserving_Key
 819         (Container : in out Set;
 820          Position  : Cursor;
 821          Process   : not null access procedure (Element : in out Element_Type))
 822       is
 823       begin
 824          if not Has_Element (Container, Position) then
 825             raise Constraint_Error with
 826               "Position cursor has no element";
 827          end if;
 828
 829          pragma Assert (Vet (Container, Position.Node),
 830                         "bad cursor in Update_Element_Preserving_Key");
 831
 832          declare
 833             N : Tree_Types.Nodes_Type renames Container.Nodes;
 834
 835             E : Element_Type renames N (Position.Node).Element;
 836             K : constant Key_Type := Key (E);
 837
 838             B : Natural renames Container.Busy;
 839             L : Natural renames Container.Lock;
 840
 841          begin
 842             B := B + 1;
 843             L := L + 1;
 844
 845             begin
 846                Process (E);
 847             exception
 848                when others =>
 849                   L := L - 1;
 850                   B := B - 1;
 851                   raise;
 852             end;
 853
 854             L := L - 1;
 855             B := B - 1;
 856
 857             if Equivalent_Keys (K, Key (E)) then
 858                return;
 859             end if;
 860          end;
 861
 862          declare
 863             X : constant Count_Type := Position.Node;
 864          begin
 865             Tree_Operations.Delete_Node_Sans_Free (Container, X);
 866             Formal_Ordered_Sets.Free (Container, X);
 867          end;
 868
 869          raise Program_Error with "key was modified";
 870       end Update_Element_Preserving_Key;
 871
 872    end Generic_Keys;
 873
 874    -----------------
 875    -- Has_Element --
 876    -----------------
 877
 878    function Has_Element (Container : Set; Position : Cursor) return Boolean is
 879    begin
 880       if Position.Node = 0 then
 881          return False;
 882       else
 883          return Container.Nodes (Position.Node).Has_Element;
 884       end if;
 885    end Has_Element;
 886
 887    -------------
 888    -- Include --
 889    -------------
 890
 891    procedure Include (Container : in out Set; New_Item : Element_Type) is
 892       Position : Cursor;
 893       Inserted : Boolean;
 894
 895    begin
 896       Insert (Container, New_Item, Position, Inserted);
 897
 898       if not Inserted then
 899          if Container.Lock > 0 then
 900             raise Program_Error with
 901               "attempt to tamper with cursors (set is locked)";
 902          end if;
 903
 904          declare
 905             N : Tree_Types.Nodes_Type renames Container.Nodes;
 906          begin
 907             N (Position.Node).Element := New_Item;
 908          end;
 909       end if;
 910    end Include;
 911
 912    ------------
 913    -- Insert --
 914    ------------
 915
 916    procedure Insert
 917      (Container : in out Set;
 918       New_Item  : Element_Type;
 919       Position  : out Cursor;
 920       Inserted  : out Boolean)
 921    is
 922    begin
 923       Insert_Sans_Hint (Container, New_Item, Position.Node, Inserted);
 924    end Insert;
 925
 926    procedure Insert
 927      (Container : in out Set;
 928       New_Item  : Element_Type)
 929    is
 930       Position : Cursor;
 931       Inserted : Boolean;
 932
 933    begin
 934       Insert (Container, New_Item, Position, Inserted);
 935
 936       if not Inserted then
 937          raise Constraint_Error with
 938            "attempt to insert element already in set";
 939       end if;
 940    end Insert;
 941
 942    ----------------------
 943    -- Insert_Sans_Hint --
 944    ----------------------
 945
 946    procedure Insert_Sans_Hint
 947      (Container : in out Set;
 948       New_Item  : Element_Type;
 949       Node      : out Count_Type;
 950       Inserted  : out Boolean)
 951    is
 952       procedure Set_Element (Node : in out Node_Type);
 953
 954       function New_Node return Count_Type;
 955       pragma Inline (New_Node);
 956
 957       procedure Insert_Post is
 958         new Element_Keys.Generic_Insert_Post (New_Node);
 959
 960       procedure Conditional_Insert_Sans_Hint is
 961         new Element_Keys.Generic_Conditional_Insert (Insert_Post);
 962
 963       procedure Allocate is new Generic_Allocate (Set_Element);
 964
 965       --------------
 966       -- New_Node --
 967       --------------
 968
 969       function New_Node return Count_Type is
 970          Result : Count_Type;
 971       begin
 972          Allocate (Container, Result);
 973          return Result;
 974       end New_Node;
 975
 976       -----------------
 977       -- Set_Element --
 978       -----------------
 979
 980       procedure Set_Element (Node : in out Node_Type) is
 981       begin
 982          Node.Element := New_Item;
 983       end Set_Element;
 984
 985    --  Start of processing for Insert_Sans_Hint
 986
 987    begin
 988       Conditional_Insert_Sans_Hint
 989         (Container,
 990          New_Item,
 991          Node,
 992          Inserted);
 993    end Insert_Sans_Hint;
 994
 995    ----------------------
 996    -- Insert_With_Hint --
 997    ----------------------
 998
 999    procedure Insert_With_Hint
1000      (Dst_Set  : in out Set;
1001       Dst_Hint : Count_Type;
1002       Src_Node : Node_Type;
1003       Dst_Node : out Count_Type)
1004    is
1005       Success : Boolean;
1006       pragma Unreferenced (Success);
1007
1008       procedure Set_Element (Node : in out Node_Type);
1009
1010       function New_Node return Count_Type;
1011       pragma Inline (New_Node);
1012
1013       procedure Insert_Post is
1014         new Element_Keys.Generic_Insert_Post (New_Node);
1015
1016       procedure Insert_Sans_Hint is
1017         new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1018
1019       procedure Local_Insert_With_Hint is
1020         new Element_Keys.Generic_Conditional_Insert_With_Hint
1021               (Insert_Post, Insert_Sans_Hint);
1022
1023       procedure Allocate is new Generic_Allocate (Set_Element);
1024
1025       --------------
1026       -- New_Node --
1027       --------------
1028
1029       function New_Node return Count_Type is
1030          Result : Count_Type;
1031       begin
1032          Allocate (Dst_Set, Result);
1033          return Result;
1034       end New_Node;
1035
1036       -----------------
1037       -- Set_Element --
1038       -----------------
1039
1040       procedure Set_Element (Node : in out Node_Type) is
1041       begin
1042          Node.Element := Src_Node.Element;
1043       end Set_Element;
1044
1045    --  Start of processing for Insert_With_Hint
1046
1047    begin
1048       Local_Insert_With_Hint
1049         (Dst_Set,
1050          Dst_Hint,
1051          Src_Node.Element,
1052          Dst_Node,
1053          Success);
1054    end Insert_With_Hint;
1055
1056    ------------------
1057    -- Intersection --
1058    ------------------
1059
1060    procedure Intersection (Target : in out Set; Source : Set) is
1061    begin
1062       Set_Ops.Set_Intersection (Target, Source);
1063    end Intersection;
1064
1065    function Intersection (Left, Right : Set) return Set is
1066    begin
1067       if Left'Address = Right'Address then
1068          return Left.Copy;
1069       end if;
1070
1071       return S : Set (Count_Type'Min (Length (Left), Length (Right))) do
1072             Assign (S, Set_Ops.Set_Intersection (Left, Right));
1073       end return;
1074    end Intersection;
1075
1076    --------------
1077    -- Is_Empty --
1078    --------------
1079
1080    function Is_Empty (Container : Set) return Boolean is
1081    begin
1082       return Length (Container) = 0;
1083    end Is_Empty;
1084
1085    -----------------------------
1086    -- Is_Greater_Element_Node --
1087    -----------------------------
1088
1089    function Is_Greater_Element_Node
1090      (Left  : Element_Type;
1091       Right : Node_Type) return Boolean
1092    is
1093    begin
1094       --  Compute e > node same as node < e
1095
1096       return Right.Element < Left;
1097    end Is_Greater_Element_Node;
1098
1099    --------------------------
1100    -- Is_Less_Element_Node --
1101    --------------------------
1102
1103    function Is_Less_Element_Node
1104      (Left  : Element_Type;
1105       Right : Node_Type) return Boolean
1106    is
1107    begin
1108       return Left < Right.Element;
1109    end Is_Less_Element_Node;
1110
1111    -----------------------
1112    -- Is_Less_Node_Node --
1113    -----------------------
1114
1115    function Is_Less_Node_Node (L, R : Node_Type) return Boolean is
1116    begin
1117       return L.Element < R.Element;
1118    end Is_Less_Node_Node;
1119
1120    ---------------
1121    -- Is_Subset --
1122    ---------------
1123
1124    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1125    begin
1126       return Set_Ops.Set_Subset (Subset, Of_Set => Of_Set);
1127    end Is_Subset;
1128
1129    -------------
1130    -- Iterate --
1131    -------------
1132
1133    procedure Iterate
1134      (Container : Set;
1135       Process   : not null access procedure (Container : Set;
1136                                              Position : Cursor))
1137    is
1138       procedure Process_Node (Node : Count_Type);
1139       pragma Inline (Process_Node);
1140
1141       procedure Local_Iterate is
1142         new Tree_Operations.Generic_Iteration (Process_Node);
1143
1144       ------------------
1145       -- Process_Node --
1146       ------------------
1147
1148       procedure Process_Node (Node : Count_Type) is
1149       begin
1150          Process (Container, (Node => Node));
1151       end Process_Node;
1152
1153       --  Local variables
1154
1155       B : Natural renames Container'Unrestricted_Access.Busy;
1156
1157    --  Start of prccessing for Iterate
1158
1159    begin
1160       B := B + 1;
1161
1162       begin
1163          Local_Iterate (Container);
1164       exception
1165          when others =>
1166             B := B - 1;
1167             raise;
1168       end;
1169
1170       B := B - 1;
1171    end Iterate;
1172
1173    ----------
1174    -- Last --
1175    ----------
1176
1177    function Last (Container : Set) return Cursor is
1178    begin
1179       return (if Length (Container) = 0
1180               then No_Element
1181               else (Node => Container.Last));
1182    end Last;
1183
1184    ------------------
1185    -- Last_Element --
1186    ------------------
1187
1188    function Last_Element (Container : Set) return Element_Type is
1189    begin
1190       if Last (Container).Node = 0 then
1191          raise Constraint_Error with "set is empty";
1192       end if;
1193
1194       declare
1195          N : Tree_Types.Nodes_Type renames Container.Nodes;
1196       begin
1197          return N (Last (Container).Node).Element;
1198       end;
1199    end Last_Element;
1200
1201    ----------
1202    -- Left --
1203    ----------
1204
1205    function Left (Container : Set; Position : Cursor) return Set is
1206       Curs : Cursor := Position;
1207       C    : Set (Container.Capacity) := Copy (Container, Container.Capacity);
1208       Node : Count_Type;
1209
1210    begin
1211       if Curs = No_Element then
1212          return C;
1213       end if;
1214
1215       if not Has_Element (Container, Curs) then
1216          raise Constraint_Error;
1217       end if;
1218
1219       while Curs.Node /= 0 loop
1220          Node := Curs.Node;
1221          Delete (C, Curs);
1222          Curs := Next (Container, (Node => Node));
1223       end loop;
1224
1225       return C;
1226    end Left;
1227
1228    --------------
1229    -- Left_Son --
1230    --------------
1231
1232    function Left_Son (Node : Node_Type) return Count_Type is
1233    begin
1234       return Node.Left;
1235    end Left_Son;
1236
1237    ------------
1238    -- Length --
1239    ------------
1240
1241    function Length (Container : Set) return Count_Type is
1242    begin
1243       return Container.Length;
1244    end Length;
1245
1246    ----------
1247    -- Move --
1248    ----------
1249
1250    procedure Move (Target : in out Set; Source : in out Set) is
1251       N : Tree_Types.Nodes_Type renames Source.Nodes;
1252       X : Count_Type;
1253
1254    begin
1255       if Target'Address = Source'Address then
1256          return;
1257       end if;
1258
1259       if Target.Capacity < Length (Source) then
1260          raise Constraint_Error with  -- ???
1261            "Source length exceeds Target capacity";
1262       end if;
1263
1264       if Source.Busy > 0 then
1265          raise Program_Error with
1266            "attempt to tamper with cursors of Source (list is busy)";
1267       end if;
1268
1269       Clear (Target);
1270
1271       loop
1272          X := Source.First;
1273          exit when X = 0;
1274
1275          Insert (Target, N (X).Element);  -- optimize???
1276
1277          Tree_Operations.Delete_Node_Sans_Free (Source, X);
1278          Formal_Ordered_Sets.Free (Source, X);
1279       end loop;
1280    end Move;
1281
1282    ----------
1283    -- Next --
1284    ----------
1285
1286    function Next (Container : Set; Position : Cursor) return Cursor is
1287    begin
1288       if Position = No_Element then
1289          return No_Element;
1290       end if;
1291
1292       if not Has_Element (Container, Position) then
1293          raise Constraint_Error;
1294       end if;
1295
1296       pragma Assert (Vet (Container, Position.Node),
1297                      "bad cursor in Next");
1298       return (Node => Tree_Operations.Next (Container, Position.Node));
1299    end Next;
1300
1301    procedure Next (Container : Set; Position : in out Cursor) is
1302    begin
1303       Position := Next (Container, Position);
1304    end Next;
1305
1306    -------------
1307    -- Overlap --
1308    -------------
1309
1310    function Overlap (Left, Right : Set) return Boolean is
1311    begin
1312       return Set_Ops.Set_Overlap (Left, Right);
1313    end Overlap;
1314
1315    ------------
1316    -- Parent --
1317    ------------
1318
1319    function Parent (Node : Node_Type) return Count_Type is
1320    begin
1321       return Node.Parent;
1322    end Parent;
1323
1324    --------------
1325    -- Previous --
1326    --------------
1327
1328    function Previous (Container : Set; Position : Cursor) return Cursor is
1329    begin
1330       if Position = No_Element then
1331          return No_Element;
1332       end if;
1333
1334       if not Has_Element (Container, Position) then
1335          raise Constraint_Error;
1336       end if;
1337
1338       pragma Assert (Vet (Container, Position.Node),
1339                      "bad cursor in Previous");
1340
1341       declare
1342          Node : constant Count_Type :=
1343                   Tree_Operations.Previous (Container, Position.Node);
1344       begin
1345          return (if Node = 0 then No_Element else (Node => Node));
1346       end;
1347    end Previous;
1348
1349    procedure Previous (Container : Set; Position : in out Cursor) is
1350    begin
1351       Position := Previous (Container, Position);
1352    end Previous;
1353
1354    -------------------
1355    -- Query_Element --
1356    -------------------
1357
1358    procedure Query_Element
1359      (Container : in out Set;
1360       Position  : Cursor;
1361       Process   : not null access procedure (Element : Element_Type))
1362    is
1363    begin
1364       if not Has_Element (Container, Position) then
1365          raise Constraint_Error with "Position cursor has no element";
1366       end if;
1367
1368       pragma Assert (Vet (Container, Position.Node),
1369                      "bad cursor in Query_Element");
1370
1371       declare
1372          B : Natural renames Container.Busy;
1373          L : Natural renames Container.Lock;
1374
1375       begin
1376          B := B + 1;
1377          L := L + 1;
1378
1379          begin
1380             Process (Container.Nodes (Position.Node).Element);
1381          exception
1382             when others =>
1383                L := L - 1;
1384                B := B - 1;
1385                raise;
1386          end;
1387
1388          L := L - 1;
1389          B := B - 1;
1390       end;
1391    end Query_Element;
1392
1393    ----------
1394    -- Read --
1395    ----------
1396
1397    procedure Read
1398      (Stream    : not null access Root_Stream_Type'Class;
1399       Container : out Set)
1400    is
1401       procedure Read_Element (Node : in out Node_Type);
1402       pragma Inline (Read_Element);
1403
1404       procedure Allocate is
1405         new Generic_Allocate (Read_Element);
1406
1407       procedure Read_Elements is
1408         new Tree_Operations.Generic_Read (Allocate);
1409
1410       ------------------
1411       -- Read_Element --
1412       ------------------
1413
1414       procedure Read_Element (Node : in out Node_Type) is
1415       begin
1416          Element_Type'Read (Stream, Node.Element);
1417       end Read_Element;
1418
1419    --  Start of processing for Read
1420
1421    begin
1422       Read_Elements (Stream, Container);
1423    end Read;
1424
1425    procedure Read
1426      (Stream : not null access Root_Stream_Type'Class;
1427       Item   : out Cursor)
1428    is
1429    begin
1430       raise Program_Error with "attempt to stream set cursor";
1431    end Read;
1432
1433    -------------
1434    -- Replace --
1435    -------------
1436
1437    procedure Replace (Container : in out Set; New_Item : Element_Type) is
1438       Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
1439
1440    begin
1441       if Node = 0 then
1442          raise Constraint_Error with
1443            "attempt to replace element not in set";
1444       end if;
1445
1446       if Container.Lock > 0 then
1447          raise Program_Error with
1448            "attempt to tamper with cursors (set is locked)";
1449       end if;
1450
1451       Container.Nodes (Node).Element := New_Item;
1452    end Replace;
1453
1454    ---------------------
1455    -- Replace_Element --
1456    ---------------------
1457
1458    procedure Replace_Element
1459      (Tree : in out Set;
1460       Node : Count_Type;
1461       Item : Element_Type)
1462    is
1463       pragma Assert (Node /= 0);
1464
1465       function New_Node return Count_Type;
1466       pragma Inline (New_Node);
1467
1468       procedure Local_Insert_Post is
1469         new Element_Keys.Generic_Insert_Post (New_Node);
1470
1471       procedure Local_Insert_Sans_Hint is
1472         new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
1473
1474       procedure Local_Insert_With_Hint is
1475         new Element_Keys.Generic_Conditional_Insert_With_Hint
1476           (Local_Insert_Post,
1477            Local_Insert_Sans_Hint);
1478
1479       NN : Tree_Types.Nodes_Type renames Tree.Nodes;
1480
1481       --------------
1482       -- New_Node --
1483       --------------
1484
1485       function New_Node return Count_Type is
1486          N  : Node_Type renames NN (Node);
1487       begin
1488          N.Element := Item;
1489          N.Color   := Red;
1490          N.Parent  := 0;
1491          N.Right   := 0;
1492          N.Left    := 0;
1493          return Node;
1494       end New_Node;
1495
1496       Hint      : Count_Type;
1497       Result    : Count_Type;
1498       Inserted  : Boolean;
1499
1500    --  Start of processing for Insert
1501
1502    begin
1503       if Item < NN (Node).Element
1504         or else NN (Node).Element < Item
1505       then
1506          null;
1507
1508       else
1509          if Tree.Lock > 0 then
1510             raise Program_Error with
1511               "attempt to tamper with cursors (set is locked)";
1512          end if;
1513
1514          NN (Node).Element := Item;
1515          return;
1516       end if;
1517
1518       Hint := Element_Keys.Ceiling (Tree, Item);
1519
1520       if Hint = 0 then
1521          null;
1522
1523       elsif Item < NN (Hint).Element then
1524          if Hint = Node then
1525             if Tree.Lock > 0 then
1526                raise Program_Error with
1527                  "attempt to tamper with cursors (set is locked)";
1528             end if;
1529
1530             NN (Node).Element := Item;
1531             return;
1532          end if;
1533
1534       else
1535          pragma Assert (not (NN (Hint).Element < Item));
1536          raise Program_Error with "attempt to replace existing element";
1537       end if;
1538
1539       Tree_Operations.Delete_Node_Sans_Free (Tree, Node);  -- Checks busy-bit
1540
1541       Local_Insert_With_Hint
1542         (Tree     => Tree,
1543          Position => Hint,
1544          Key      => Item,
1545          Node     => Result,
1546          Inserted => Inserted);
1547
1548       pragma Assert (Inserted);
1549       pragma Assert (Result = Node);
1550    end Replace_Element;
1551
1552    procedure Replace_Element
1553      (Container : in out Set;
1554       Position  : Cursor;
1555       New_Item  : Element_Type)
1556    is
1557    begin
1558       if not Has_Element (Container, Position) then
1559          raise Constraint_Error with
1560            "Position cursor has no element";
1561       end if;
1562
1563       pragma Assert (Vet (Container, Position.Node),
1564                      "bad cursor in Replace_Element");
1565
1566       Replace_Element (Container, Position.Node, New_Item);
1567    end Replace_Element;
1568
1569    ---------------------
1570    -- Reverse_Iterate --
1571    ---------------------
1572
1573    procedure Reverse_Iterate
1574      (Container : Set;
1575       Process   : not null access procedure (Container : Set;
1576                                              Position : Cursor))
1577    is
1578       procedure Process_Node (Node : Count_Type);
1579       pragma Inline (Process_Node);
1580
1581       procedure Local_Reverse_Iterate is
1582         new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1583
1584       ------------------
1585       -- Process_Node --
1586       ------------------
1587
1588       procedure Process_Node (Node : Count_Type) is
1589       begin
1590          Process (Container, (Node => Node));
1591       end Process_Node;
1592
1593       B : Natural renames Container'Unrestricted_Access.Busy;
1594
1595    --  Start of processing for Reverse_Iterate
1596
1597    begin
1598       B := B + 1;
1599
1600       begin
1601          Local_Reverse_Iterate (Container);
1602       exception
1603          when others =>
1604             B := B - 1;
1605             raise;
1606       end;
1607
1608       B := B - 1;
1609    end Reverse_Iterate;
1610
1611    -----------
1612    -- Right --
1613    -----------
1614
1615    function Right (Container : Set; Position : Cursor) return Set is
1616       Curs : Cursor := First (Container);
1617       C    : Set (Container.Capacity) := Copy (Container, Container.Capacity);
1618       Node : Count_Type;
1619
1620    begin
1621       if Curs = No_Element then
1622          Clear (C);
1623          return C;
1624       end if;
1625
1626       if Position /= No_Element and not Has_Element (Container, Position) then
1627          raise Constraint_Error;
1628       end if;
1629
1630       while Curs.Node /= Position.Node loop
1631          Node := Curs.Node;
1632          Delete (C, Curs);
1633          Curs := Next (Container, (Node => Node));
1634       end loop;
1635
1636       return C;
1637    end Right;
1638
1639    ---------------
1640    -- Right_Son --
1641    ---------------
1642
1643    function Right_Son (Node : Node_Type) return Count_Type is
1644    begin
1645       return Node.Right;
1646    end Right_Son;
1647
1648    ---------------
1649    -- Set_Color --
1650    ---------------
1651
1652    procedure Set_Color
1653      (Node  : in out Node_Type;
1654       Color : Red_Black_Trees.Color_Type)
1655    is
1656    begin
1657       Node.Color := Color;
1658    end Set_Color;
1659
1660    --------------
1661    -- Set_Left --
1662    --------------
1663
1664    procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
1665    begin
1666       Node.Left := Left;
1667    end Set_Left;
1668
1669    ----------------
1670    -- Set_Parent --
1671    ----------------
1672
1673    procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
1674    begin
1675       Node.Parent := Parent;
1676    end Set_Parent;
1677
1678    ---------------
1679    -- Set_Right --
1680    ---------------
1681
1682    procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
1683    begin
1684       Node.Right := Right;
1685    end Set_Right;
1686
1687    ------------------
1688    -- Strict_Equal --
1689    ------------------
1690
1691    function Strict_Equal (Left, Right : Set) return Boolean is
1692       LNode : Count_Type := First (Left).Node;
1693       RNode : Count_Type := First (Right).Node;
1694
1695    begin
1696       if Length (Left) /= Length (Right) then
1697          return False;
1698       end if;
1699
1700       while LNode = RNode loop
1701          if LNode = 0 then
1702             return True;
1703          end if;
1704
1705          if Left.Nodes (LNode).Element /=
1706            Right.Nodes (RNode).Element then
1707             exit;
1708          end if;
1709
1710          LNode := Next (Left, LNode);
1711          RNode := Next (Right, RNode);
1712       end loop;
1713
1714       return False;
1715    end Strict_Equal;
1716
1717    --------------------------
1718    -- Symmetric_Difference --
1719    --------------------------
1720
1721    procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1722    begin
1723       Set_Ops.Set_Symmetric_Difference (Target, Source);
1724    end Symmetric_Difference;
1725
1726    function Symmetric_Difference (Left, Right : Set) return Set is
1727    begin
1728       if Left'Address = Right'Address then
1729          return Empty_Set;
1730       end if;
1731
1732       if Length (Right) = 0 then
1733          return Left.Copy;
1734       end if;
1735
1736       if Length (Left) = 0 then
1737          return Right.Copy;
1738       end if;
1739
1740       return S : Set (Length (Left) + Length (Right)) do
1741          Assign (S, Set_Ops.Set_Symmetric_Difference (Left, Right));
1742       end return;
1743    end Symmetric_Difference;
1744
1745    ------------
1746    -- To_Set --
1747    ------------
1748
1749    function To_Set (New_Item : Element_Type) return Set is
1750       Node     : Count_Type;
1751       Inserted : Boolean;
1752    begin
1753       return S : Set (Capacity => 1) do
1754          Insert_Sans_Hint (S, New_Item, Node, Inserted);
1755          pragma Assert (Inserted);
1756       end return;
1757    end To_Set;
1758
1759    -----------
1760    -- Union --
1761    -----------
1762
1763    procedure Union (Target : in out Set; Source : Set) is
1764    begin
1765       Set_Ops.Set_Union (Target, Source);
1766    end Union;
1767
1768    function Union (Left, Right : Set) return Set is
1769    begin
1770       if Left'Address = Right'Address then
1771          return Left.Copy;
1772       end if;
1773
1774       if Length (Left) = 0 then
1775          return Right.Copy;
1776       end if;
1777
1778       if Length (Right) = 0 then
1779          return Left.Copy;
1780       end if;
1781
1782       return S : Set (Length (Left) + Length (Right)) do
1783          S.Assign (Source => Left);
1784          S.Union (Right);
1785       end return;
1786    end Union;
1787
1788    -----------
1789    -- Write --
1790    -----------
1791
1792    procedure Write
1793      (Stream    : not null access Root_Stream_Type'Class;
1794       Container : Set)
1795    is
1796       procedure Write_Element
1797         (Stream : not null access Root_Stream_Type'Class;
1798          Node   : Node_Type);
1799       pragma Inline (Write_Element);
1800
1801       procedure Write_Elements is
1802         new Tree_Operations.Generic_Write (Write_Element);
1803
1804       -------------------
1805       -- Write_Element --
1806       -------------------
1807
1808       procedure Write_Element
1809         (Stream : not null access Root_Stream_Type'Class;
1810          Node   : Node_Type)
1811       is
1812       begin
1813          Element_Type'Write (Stream, Node.Element);
1814       end Write_Element;
1815
1816    --  Start of processing for Write
1817
1818    begin
1819       Write_Elements (Stream, Container);
1820    end Write;
1821
1822    procedure Write
1823      (Stream : not null access Root_Stream_Type'Class;
1824       Item   : Cursor)
1825    is
1826    begin
1827       raise Program_Error with "attempt to stream set cursor";
1828    end Write;
1829
1830 end Ada.Containers.Formal_Ordered_Sets;