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