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