gcc/ada/a-cforma.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 _ M A P 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 System; use type System.Address;
  36
  37 package body Ada.Containers.Formal_Ordered_Maps is
  38
  39    -----------------------------
  40    -- Node Access Subprograms --
  41    -----------------------------
  42
  43    --  These subprograms provide a functional interface to access fields
  44    --  of a node, and a procedural interface for modifying these values.
  45
  46    function Color
  47      (Node : Node_Type) return Ada.Containers.Red_Black_Trees.Color_Type;
  48    pragma Inline (Color);
  49
  50    function Left_Son (Node : Node_Type) return Count_Type;
  51    pragma Inline (Left);
  52
  53    function Parent (Node : Node_Type) return Count_Type;
  54    pragma Inline (Parent);
  55
  56    function Right_Son (Node : Node_Type) return Count_Type;
  57    pragma Inline (Right);
  58
  59    procedure Set_Color
  60      (Node  : in out Node_Type;
  61       Color : Ada.Containers.Red_Black_Trees.Color_Type);
  62    pragma Inline (Set_Color);
  63
  64    procedure Set_Left (Node : in out Node_Type; Left : Count_Type);
  65    pragma Inline (Set_Left);
  66
  67    procedure Set_Right (Node : in out Node_Type; Right : Count_Type);
  68    pragma Inline (Set_Right);
  69
  70    procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type);
  71    pragma Inline (Set_Parent);
  72
  73    -----------------------
  74    -- Local Subprograms --
  75    -----------------------
  76
  77    --  All need comments ???
  78
  79    generic
  80       with procedure Set_Element (Node : in out Node_Type);
  81    procedure Generic_Allocate
  82      (Tree : in out Tree_Types.Tree_Type'Class;
  83       Node : out Count_Type);
  84
  85    procedure Free (Tree : in out Map; X : Count_Type);
  86
  87    function Is_Greater_Key_Node
  88      (Left  : Key_Type;
  89       Right : Node_Type) return Boolean;
  90    pragma Inline (Is_Greater_Key_Node);
  91
  92    function Is_Less_Key_Node
  93      (Left  : Key_Type;
  94       Right : Node_Type) return Boolean;
  95    pragma Inline (Is_Less_Key_Node);
  96
  97    --------------------------
  98    -- Local Instantiations --
  99    --------------------------
 100
 101    package Tree_Operations is
 102      new Red_Black_Trees.Generic_Bounded_Operations
 103        (Tree_Types => Tree_Types,
 104         Left       => Left_Son,
 105         Right      => Right_Son);
 106
 107    use Tree_Operations;
 108
 109    package Key_Ops is
 110      new Red_Black_Trees.Generic_Bounded_Keys
 111        (Tree_Operations     => Tree_Operations,
 112         Key_Type            => Key_Type,
 113         Is_Less_Key_Node    => Is_Less_Key_Node,
 114         Is_Greater_Key_Node => Is_Greater_Key_Node);
 115
 116    ---------
 117    -- "=" --
 118    ---------
 119
 120    function "=" (Left, Right : Map) return Boolean is
 121       Lst   : Count_Type;
 122       Node  : Count_Type;
 123       ENode : Count_Type;
 124
 125    begin
 126       if Length (Left) /= Length (Right) then
 127          return False;
 128       end if;
 129
 130       if Is_Empty (Left) then
 131          return True;
 132       end if;
 133
 134       Lst := Next (Left, Last (Left).Node);
 135
 136       Node := First (Left).Node;
 137       while Node /= Lst loop
 138          ENode := Find (Right, Left.Nodes (Node).Key).Node;
 139
 140          if ENode = 0 or else
 141            Left.Nodes (Node).Element /= Right.Nodes (ENode).Element
 142          then
 143             return False;
 144          end if;
 145
 146          Node := Next (Left, Node);
 147       end loop;
 148
 149       return True;
 150    end "=";
 151
 152    ------------
 153    -- Assign --
 154    ------------
 155
 156    procedure Assign (Target : in out Map; Source : Map) is
 157       procedure Append_Element (Source_Node : Count_Type);
 158
 159       procedure Append_Elements is
 160          new Tree_Operations.Generic_Iteration (Append_Element);
 161
 162       --------------------
 163       -- Append_Element --
 164       --------------------
 165
 166       procedure Append_Element (Source_Node : Count_Type) is
 167          SN : Node_Type renames Source.Nodes (Source_Node);
 168
 169          procedure Set_Element (Node : in out Node_Type);
 170          pragma Inline (Set_Element);
 171
 172          function New_Node return Count_Type;
 173          pragma Inline (New_Node);
 174
 175          procedure Insert_Post is new Key_Ops.Generic_Insert_Post (New_Node);
 176
 177          procedure Unconditional_Insert_Sans_Hint is
 178            new Key_Ops.Generic_Unconditional_Insert (Insert_Post);
 179
 180          procedure Unconditional_Insert_Avec_Hint is
 181            new Key_Ops.Generic_Unconditional_Insert_With_Hint
 182              (Insert_Post,
 183               Unconditional_Insert_Sans_Hint);
 184
 185          procedure Allocate is new Generic_Allocate (Set_Element);
 186
 187          --------------
 188          -- New_Node --
 189          --------------
 190
 191          function New_Node return Count_Type is
 192             Result : Count_Type;
 193          begin
 194             Allocate (Target, Result);
 195             return Result;
 196          end New_Node;
 197
 198          -----------------
 199          -- Set_Element --
 200          -----------------
 201
 202          procedure Set_Element (Node : in out Node_Type) is
 203          begin
 204             Node.Key := SN.Key;
 205             Node.Element := SN.Element;
 206          end Set_Element;
 207
 208          Target_Node : Count_Type;
 209
 210       --  Start of processing for Append_Element
 211
 212       begin
 213          Unconditional_Insert_Avec_Hint
 214            (Tree  => Target,
 215             Hint  => 0,
 216             Key   => SN.Key,
 217             Node  => Target_Node);
 218       end Append_Element;
 219
 220    --  Start of processing for Assign
 221
 222    begin
 223       if Target'Address = Source'Address then
 224          return;
 225       end if;
 226
 227       if Target.Capacity < Length (Source) then
 228          raise Storage_Error with "not enough capacity";  -- SE or CE? ???
 229       end if;
 230
 231       Tree_Operations.Clear_Tree (Target);
 232       Append_Elements (Source);
 233    end Assign;
 234
 235    -------------
 236    -- Ceiling --
 237    -------------
 238
 239    function Ceiling (Container : Map; Key : Key_Type) return Cursor is
 240       Node : constant Count_Type := Key_Ops.Ceiling (Container, Key);
 241
 242    begin
 243       if Node = 0 then
 244          return No_Element;
 245       end if;
 246
 247       return (Node => Node);
 248    end Ceiling;
 249
 250    -----------
 251    -- Clear --
 252    -----------
 253
 254    procedure Clear (Container : in out Map) is
 255    begin
 256       Tree_Operations.Clear_Tree (Container);
 257    end Clear;
 258
 259    -----------
 260    -- Color --
 261    -----------
 262
 263    function Color (Node : Node_Type) return Color_Type is
 264    begin
 265       return Node.Color;
 266    end Color;
 267
 268    --------------
 269    -- Contains --
 270    --------------
 271
 272    function Contains (Container : Map; Key : Key_Type) return Boolean is
 273    begin
 274       return Find (Container, Key) /= No_Element;
 275    end Contains;
 276
 277    ----------
 278    -- Copy --
 279    ----------
 280
 281    function Copy (Source : Map; Capacity : Count_Type := 0) return Map is
 282       Node : Count_Type := 1;
 283       N    : Count_Type;
 284
 285    begin
 286       if 0 < Capacity and then Capacity < Source.Capacity then
 287          raise Capacity_Error;
 288       end if;
 289
 290       return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do
 291          if Length (Source) > 0 then
 292             Target.Length := Source.Length;
 293             Target.Root := Source.Root;
 294             Target.First := Source.First;
 295             Target.Last := Source.Last;
 296             Target.Free := Source.Free;
 297
 298             while Node <= Source.Capacity loop
 299                Target.Nodes (Node).Element :=
 300                  Source.Nodes (Node).Element;
 301                Target.Nodes (Node).Key :=
 302                  Source.Nodes (Node).Key;
 303                Target.Nodes (Node).Parent :=
 304                  Source.Nodes (Node).Parent;
 305                Target.Nodes (Node).Left :=
 306                  Source.Nodes (Node).Left;
 307                Target.Nodes (Node).Right :=
 308                  Source.Nodes (Node).Right;
 309                Target.Nodes (Node).Color :=
 310                  Source.Nodes (Node).Color;
 311                Target.Nodes (Node).Has_Element :=
 312                  Source.Nodes (Node).Has_Element;
 313                Node := Node + 1;
 314             end loop;
 315
 316             while Node <= Target.Capacity loop
 317                N := Node;
 318                Formal_Ordered_Maps.Free (Tree => Target, X => N);
 319                Node := Node + 1;
 320             end loop;
 321          end if;
 322       end return;
 323    end Copy;
 324
 325    ------------
 326    -- Delete --
 327    ------------
 328
 329    procedure Delete (Container : in out Map; Position : in out Cursor) is
 330    begin
 331       if not Has_Element (Container, Position) then
 332          raise Constraint_Error with
 333            "Position cursor of Delete has no element";
 334       end if;
 335
 336       pragma Assert (Vet (Container, Position.Node),
 337                      "Position cursor of Delete is bad");
 338
 339       Tree_Operations.Delete_Node_Sans_Free (Container,
 340                                              Position.Node);
 341       Formal_Ordered_Maps.Free (Container, Position.Node);
 342    end Delete;
 343
 344    procedure Delete (Container : in out Map; Key : Key_Type) is
 345       X : constant Node_Access := Key_Ops.Find (Container, Key);
 346
 347    begin
 348       if X = 0 then
 349          raise Constraint_Error with "key not in map";
 350       end if;
 351
 352       Tree_Operations.Delete_Node_Sans_Free (Container, X);
 353       Formal_Ordered_Maps.Free (Container, X);
 354    end Delete;
 355
 356    ------------------
 357    -- Delete_First --
 358    ------------------
 359
 360    procedure Delete_First (Container : in out Map) is
 361       X : constant Node_Access := First (Container).Node;
 362    begin
 363       if X /= 0 then
 364          Tree_Operations.Delete_Node_Sans_Free (Container, X);
 365          Formal_Ordered_Maps.Free (Container, X);
 366       end if;
 367    end Delete_First;
 368
 369    -----------------
 370    -- Delete_Last --
 371    -----------------
 372
 373    procedure Delete_Last (Container : in out Map) is
 374       X : constant Node_Access := Last (Container).Node;
 375    begin
 376       if X /= 0 then
 377          Tree_Operations.Delete_Node_Sans_Free (Container, X);
 378          Formal_Ordered_Maps.Free (Container, X);
 379       end if;
 380    end Delete_Last;
 381
 382    -------------
 383    -- Element --
 384    -------------
 385
 386    function Element (Container : Map; Position : Cursor) return Element_Type is
 387    begin
 388       if not Has_Element (Container, Position) then
 389          raise Constraint_Error with
 390            "Position cursor of function Element has no element";
 391       end if;
 392
 393       pragma Assert (Vet (Container, Position.Node),
 394                      "Position cursor of function Element is bad");
 395
 396       return Container.Nodes (Position.Node).Element;
 397
 398    end Element;
 399
 400    function Element (Container : Map; Key : Key_Type) return Element_Type is
 401       Node : constant Node_Access := Find (Container, Key).Node;
 402
 403    begin
 404       if Node = 0 then
 405          raise Constraint_Error with "key not in map";
 406       end if;
 407
 408       return Container.Nodes (Node).Element;
 409    end Element;
 410
 411    ---------------------
 412    -- Equivalent_Keys --
 413    ---------------------
 414
 415    function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
 416    begin
 417       if Left < Right
 418         or else Right < Left
 419       then
 420          return False;
 421       else
 422          return True;
 423       end if;
 424    end Equivalent_Keys;
 425
 426    -------------
 427    -- Exclude --
 428    -------------
 429
 430    procedure Exclude (Container : in out Map; Key : Key_Type) is
 431       X : constant Node_Access := Key_Ops.Find (Container, Key);
 432    begin
 433       if X /= 0 then
 434          Tree_Operations.Delete_Node_Sans_Free (Container, X);
 435          Formal_Ordered_Maps.Free (Container, X);
 436       end if;
 437    end Exclude;
 438
 439    ----------
 440    -- Find --
 441    ----------
 442
 443    function Find (Container : Map; Key : Key_Type) return Cursor is
 444       Node : constant Count_Type := Key_Ops.Find (Container, Key);
 445
 446    begin
 447       if Node = 0 then
 448          return No_Element;
 449       end if;
 450
 451       return (Node => Node);
 452    end Find;
 453
 454    -----------
 455    -- First --
 456    -----------
 457
 458    function First (Container : Map) return Cursor is
 459    begin
 460       if Length (Container) = 0 then
 461          return No_Element;
 462       end if;
 463
 464       return (Node => Container.First);
 465    end First;
 466
 467    -------------------
 468    -- First_Element --
 469    -------------------
 470
 471    function First_Element (Container : Map) return Element_Type is
 472    begin
 473       if Is_Empty (Container) then
 474          raise Constraint_Error with "map is empty";
 475       end if;
 476
 477       return Container.Nodes (First (Container).Node).Element;
 478    end First_Element;
 479
 480    ---------------
 481    -- First_Key --
 482    ---------------
 483
 484    function First_Key (Container : Map) return Key_Type is
 485    begin
 486       if Is_Empty (Container) then
 487          raise Constraint_Error with "map is empty";
 488       end if;
 489
 490       return Container.Nodes (First (Container).Node).Key;
 491    end First_Key;
 492
 493    -----------
 494    -- Floor --
 495    -----------
 496
 497    function Floor (Container : Map; Key : Key_Type) return Cursor is
 498       Node : constant Count_Type := Key_Ops.Floor (Container, Key);
 499
 500    begin
 501       if Node = 0 then
 502          return No_Element;
 503       end if;
 504
 505       return (Node => Node);
 506    end Floor;
 507
 508    ----------
 509    -- Free --
 510    ----------
 511
 512    procedure Free
 513      (Tree : in out Map;
 514       X  : Count_Type)
 515    is
 516    begin
 517       Tree.Nodes (X).Has_Element := False;
 518       Tree_Operations.Free (Tree, X);
 519    end Free;
 520
 521    ----------------------
 522    -- Generic_Allocate --
 523    ----------------------
 524
 525    procedure Generic_Allocate
 526      (Tree : in out Tree_Types.Tree_Type'Class;
 527       Node : out Count_Type)
 528    is
 529       procedure Allocate is
 530         new Tree_Operations.Generic_Allocate (Set_Element);
 531    begin
 532       Allocate (Tree, Node);
 533       Tree.Nodes (Node).Has_Element := True;
 534    end Generic_Allocate;
 535
 536    -----------------
 537    -- Has_Element --
 538    -----------------
 539
 540    function Has_Element (Container : Map; Position : Cursor) return Boolean is
 541    begin
 542       if Position.Node = 0 then
 543          return False;
 544       end if;
 545
 546       return Container.Nodes (Position.Node).Has_Element;
 547    end Has_Element;
 548
 549    -------------
 550    -- Include --
 551    -------------
 552
 553    procedure Include
 554      (Container : in out Map;
 555       Key       : Key_Type;
 556       New_Item  : Element_Type)
 557    is
 558       Position : Cursor;
 559       Inserted : Boolean;
 560
 561    begin
 562       Insert (Container, Key, New_Item, Position, Inserted);
 563
 564       if not Inserted then
 565          declare
 566             N : Node_Type renames Container.Nodes (Position.Node);
 567          begin
 568             N.Key := Key;
 569             N.Element := New_Item;
 570          end;
 571       end if;
 572    end Include;
 573
 574    procedure Insert
 575      (Container : in out Map;
 576       Key       : Key_Type;
 577       New_Item  : Element_Type;
 578       Position  : out Cursor;
 579       Inserted  : out Boolean)
 580    is
 581       function New_Node return Node_Access;
 582       --  Comment ???
 583
 584       procedure Insert_Post is
 585         new Key_Ops.Generic_Insert_Post (New_Node);
 586
 587       procedure Insert_Sans_Hint is
 588         new Key_Ops.Generic_Conditional_Insert (Insert_Post);
 589
 590       --------------
 591       -- New_Node --
 592       --------------
 593
 594       function New_Node return Node_Access is
 595          procedure Initialize (Node : in out Node_Type);
 596          procedure Allocate_Node is new Generic_Allocate (Initialize);
 597
 598          procedure Initialize (Node : in out Node_Type) is
 599          begin
 600             Node.Key := Key;
 601             Node.Element := New_Item;
 602          end Initialize;
 603
 604          X : Node_Access;
 605
 606       begin
 607          Allocate_Node (Container, X);
 608          return X;
 609       end New_Node;
 610
 611    --  Start of processing for Insert
 612
 613    begin
 614       Insert_Sans_Hint
 615         (Container,
 616          Key,
 617          Position.Node,
 618          Inserted);
 619    end Insert;
 620
 621    procedure Insert
 622      (Container : in out Map;
 623       Key       : Key_Type;
 624       New_Item  : Element_Type)
 625    is
 626       Position : Cursor;
 627       Inserted : Boolean;
 628
 629    begin
 630       Insert (Container, Key, New_Item, Position, Inserted);
 631
 632       if not Inserted then
 633          raise Constraint_Error with "key already in map";
 634       end if;
 635    end Insert;
 636
 637    --------------
 638    -- Is_Empty --
 639    --------------
 640
 641    function Is_Empty (Container : Map) return Boolean is
 642    begin
 643       return Length (Container) = 0;
 644    end Is_Empty;
 645
 646    -------------------------
 647    -- Is_Greater_Key_Node --
 648    -------------------------
 649
 650    function Is_Greater_Key_Node
 651      (Left  : Key_Type;
 652       Right : Node_Type) return Boolean
 653    is
 654    begin
 655       --  k > node same as node < k
 656
 657       return Right.Key < Left;
 658    end Is_Greater_Key_Node;
 659
 660    ----------------------
 661    -- Is_Less_Key_Node --
 662    ----------------------
 663
 664    function Is_Less_Key_Node
 665      (Left  : Key_Type;
 666       Right : Node_Type) return Boolean
 667    is
 668    begin
 669       return Left < Right.Key;
 670    end Is_Less_Key_Node;
 671
 672    ---------
 673    -- Key --
 674    ---------
 675
 676    function Key (Container : Map; Position : Cursor) return Key_Type is
 677    begin
 678       if not Has_Element (Container, Position) then
 679          raise Constraint_Error with
 680            "Position cursor of function Key has no element";
 681       end if;
 682
 683       pragma Assert (Vet (Container, Position.Node),
 684                      "Position cursor of function Key is bad");
 685
 686       return Container.Nodes (Position.Node).Key;
 687    end Key;
 688
 689    ----------
 690    -- Last --
 691    ----------
 692
 693    function Last (Container : Map) return Cursor is
 694    begin
 695       if Length (Container) = 0 then
 696          return No_Element;
 697       end if;
 698
 699       return (Node => Container.Last);
 700    end Last;
 701
 702    ------------------
 703    -- Last_Element --
 704    ------------------
 705
 706    function Last_Element (Container : Map) return Element_Type is
 707    begin
 708       if Is_Empty (Container) then
 709          raise Constraint_Error with "map is empty";
 710       end if;
 711
 712       return Container.Nodes (Last (Container).Node).Element;
 713    end Last_Element;
 714
 715    --------------
 716    -- Last_Key --
 717    --------------
 718
 719    function Last_Key (Container : Map) return Key_Type is
 720    begin
 721       if Is_Empty (Container) then
 722          raise Constraint_Error with "map is empty";
 723       end if;
 724
 725       return Container.Nodes (Last (Container).Node).Key;
 726    end Last_Key;
 727
 728    ----------
 729    -- Left --
 730    ----------
 731
 732    function Left (Container : Map; Position : Cursor) return Map is
 733       Curs : Cursor := Position;
 734       C    : Map (Container.Capacity) := Copy (Container, Container.Capacity);
 735       Node : Count_Type;
 736
 737    begin
 738       if Curs = No_Element then
 739          return C;
 740       end if;
 741
 742       if not Has_Element (Container, Curs) then
 743          raise Constraint_Error;
 744       end if;
 745
 746       while Curs.Node /= 0 loop
 747          Node := Curs.Node;
 748          Delete (C, Curs);
 749          Curs := Next (Container, (Node => Node));
 750       end loop;
 751
 752       return C;
 753    end Left;
 754
 755    --------------
 756    -- Left_Son --
 757    --------------
 758
 759    function Left_Son (Node : Node_Type) return Count_Type is
 760    begin
 761       return Node.Left;
 762    end Left_Son;
 763
 764    ------------
 765    -- Length --
 766    ------------
 767
 768    function Length (Container : Map) return Count_Type is
 769    begin
 770       return Container.Length;
 771    end Length;
 772
 773    ----------
 774    -- Move --
 775    ----------
 776
 777    procedure Move (Target : in out Map; Source : in out Map) is
 778       NN : Tree_Types.Nodes_Type renames Source.Nodes;
 779       X  : Node_Access;
 780
 781    begin
 782       if Target'Address = Source'Address then
 783          return;
 784       end if;
 785
 786       if Target.Capacity < Length (Source) then
 787          raise Constraint_Error with  -- ???
 788            "Source length exceeds Target capacity";
 789       end if;
 790
 791       Clear (Target);
 792
 793       loop
 794          X := First (Source).Node;
 795          exit when X = 0;
 796
 797          --  Here we insert a copy of the source element into the target, and
 798          --  then delete the element from the source. Another possibility is
 799          --  that delete it first (and hang onto its index), then insert it.
 800          --  ???
 801
 802          Insert (Target, NN (X).Key, NN (X).Element);  -- optimize???
 803
 804          Tree_Operations.Delete_Node_Sans_Free (Source, X);
 805          Formal_Ordered_Maps.Free (Source, X);
 806       end loop;
 807    end Move;
 808
 809    ----------
 810    -- Next --
 811    ----------
 812
 813    procedure Next (Container : Map; Position : in out Cursor) is
 814    begin
 815       Position := Next (Container, Position);
 816    end Next;
 817
 818    function Next (Container : Map; Position : Cursor) return Cursor is
 819    begin
 820       if Position = No_Element then
 821          return No_Element;
 822       end if;
 823
 824       if not Has_Element (Container, Position) then
 825          raise Constraint_Error;
 826       end if;
 827
 828       pragma Assert (Vet (Container, Position.Node),
 829                      "bad cursor in Next");
 830
 831       return (Node => Tree_Operations.Next (Container, Position.Node));
 832    end Next;
 833
 834    -------------
 835    -- Overlap --
 836    -------------
 837
 838    function Overlap (Left, Right : Map) return Boolean is
 839    begin
 840       if Length (Left) = 0 or Length (Right) = 0 then
 841          return False;
 842       end if;
 843
 844       declare
 845          L_Node : Count_Type          := First (Left).Node;
 846          R_Node : Count_Type          := First (Right).Node;
 847          L_Last : constant Count_Type := Next (Left, Last (Left).Node);
 848          R_Last : constant Count_Type := Next (Right, Last (Right).Node);
 849
 850       begin
 851          if Left'Address = Right'Address then
 852             return True;
 853          end if;
 854
 855          loop
 856             if L_Node = L_Last
 857               or else R_Node = R_Last
 858             then
 859                return False;
 860             end if;
 861
 862             if Left.Nodes (L_Node).Key < Right.Nodes (R_Node).Key then
 863                L_Node := Next (Left, L_Node);
 864
 865             elsif Right.Nodes (R_Node).Key < Left.Nodes (L_Node).Key then
 866                R_Node := Next (Right, R_Node);
 867
 868             else
 869                return True;
 870             end if;
 871          end loop;
 872       end;
 873    end Overlap;
 874
 875    ------------
 876    -- Parent --
 877    ------------
 878
 879    function Parent (Node : Node_Type) return Count_Type is
 880    begin
 881       return Node.Parent;
 882    end Parent;
 883
 884    --------------
 885    -- Previous --
 886    --------------
 887
 888    procedure Previous (Container : Map; Position : in out Cursor) is
 889    begin
 890       Position := Previous (Container, Position);
 891    end Previous;
 892
 893    function Previous (Container : Map; Position : Cursor) return Cursor is
 894    begin
 895       if Position = No_Element then
 896          return No_Element;
 897       end if;
 898
 899       if not Has_Element (Container, Position) then
 900          raise Constraint_Error;
 901       end if;
 902
 903       pragma Assert (Vet (Container, Position.Node),
 904                      "bad cursor in Previous");
 905
 906       declare
 907          Node : constant Count_Type :=
 908            Tree_Operations.Previous (Container, Position.Node);
 909
 910       begin
 911          if Node = 0 then
 912             return No_Element;
 913          end if;
 914
 915          return (Node => Node);
 916       end;
 917    end Previous;
 918
 919    -------------
 920    -- Replace --
 921    -------------
 922
 923    procedure Replace
 924      (Container : in out Map;
 925       Key       : Key_Type;
 926       New_Item  : Element_Type)
 927    is
 928    begin
 929       declare
 930          Node : constant Node_Access := Key_Ops.Find (Container, Key);
 931
 932       begin
 933          if Node = 0 then
 934             raise Constraint_Error with "key not in map";
 935          end if;
 936
 937          declare
 938             N : Node_Type renames Container.Nodes (Node);
 939          begin
 940             N.Key := Key;
 941             N.Element := New_Item;
 942          end;
 943       end;
 944    end Replace;
 945
 946    ---------------------
 947    -- Replace_Element --
 948    ---------------------
 949
 950    procedure Replace_Element
 951      (Container : in out Map;
 952       Position  : Cursor;
 953       New_Item  : Element_Type)
 954    is
 955    begin
 956       if not Has_Element (Container, Position) then
 957          raise Constraint_Error with
 958            "Position cursor of Replace_Element has no element";
 959       end if;
 960
 961       pragma Assert (Vet (Container, Position.Node),
 962                      "Position cursor of Replace_Element is bad");
 963
 964       Container.Nodes (Position.Node).Element := New_Item;
 965    end Replace_Element;
 966
 967    -----------
 968    -- Right --
 969    -----------
 970
 971    function Right (Container : Map; Position : Cursor) return Map is
 972       Curs : Cursor := First (Container);
 973       C    : Map (Container.Capacity) := Copy (Container, Container.Capacity);
 974       Node : Count_Type;
 975
 976    begin
 977       if Curs = No_Element then
 978          Clear (C);
 979          return C;
 980
 981       end if;
 982       if Position /= No_Element and not Has_Element (Container, Position) then
 983          raise Constraint_Error;
 984       end if;
 985
 986       while Curs.Node /= Position.Node loop
 987          Node := Curs.Node;
 988          Delete (C, Curs);
 989          Curs := Next (Container, (Node => Node));
 990       end loop;
 991
 992       return C;
 993    end Right;
 994
 995    ---------------
 996    -- Right_Son --
 997    ---------------
 998
 999    function Right_Son (Node : Node_Type) return Count_Type is
1000    begin
1001       return Node.Right;
1002    end Right_Son;
1003
1004    ---------------
1005    -- Set_Color --
1006    ---------------
1007
1008    procedure Set_Color (Node  : in out Node_Type; Color : Color_Type) is
1009    begin
1010       Node.Color := Color;
1011    end Set_Color;
1012
1013    --------------
1014    -- Set_Left --
1015    --------------
1016
1017    procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
1018    begin
1019       Node.Left := Left;
1020    end Set_Left;
1021
1022    ----------------
1023    -- Set_Parent --
1024    ----------------
1025
1026    procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
1027    begin
1028       Node.Parent := Parent;
1029    end Set_Parent;
1030
1031    ---------------
1032    -- Set_Right --
1033    ---------------
1034
1035    procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
1036    begin
1037       Node.Right := Right;
1038    end Set_Right;
1039
1040    ------------------
1041    -- Strict_Equal --
1042    ------------------
1043
1044    function Strict_Equal (Left, Right : Map) return Boolean is
1045       LNode : Count_Type := First (Left).Node;
1046       RNode : Count_Type := First (Right).Node;
1047
1048    begin
1049       if Length (Left) /= Length (Right) then
1050          return False;
1051       end if;
1052
1053       while LNode = RNode loop
1054          if LNode = 0 then
1055             return True;
1056          end if;
1057
1058          if Left.Nodes (LNode).Element /= Right.Nodes (RNode).Element
1059            or else Left.Nodes (LNode).Key /= Right.Nodes (RNode).Key
1060          then
1061             exit;
1062          end if;
1063
1064          LNode := Next (Left, LNode);
1065          RNode := Next (Right, RNode);
1066       end loop;
1067
1068       return False;
1069    end Strict_Equal;
1070
1071 end Ada.Containers.Formal_Ordered_Maps;