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