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