gcc/ada/a-cforma.adb

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