main/gcc/ada/a-cforma.adb

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