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