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