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-2011, 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          if Container.Lock > 0 then
 562             raise Program_Error with
 563               "attempt to tamper with cursors (map is locked)";
 564          end if;
 565
 566          declare
 567             N : Node_Type renames Container.Nodes (Position.Node);
 568          begin
 569             N.Key := Key;
 570             N.Element := New_Item;
 571          end;
 572       end if;
 573    end Include;
 574
 575    procedure Insert
 576      (Container : in out Map;
 577       Key       : Key_Type;
 578       New_Item  : Element_Type;
 579       Position  : out Cursor;
 580       Inserted  : out Boolean)
 581    is
 582       function New_Node return Node_Access;
 583       --  Comment ???
 584
 585       procedure Insert_Post is
 586         new Key_Ops.Generic_Insert_Post (New_Node);
 587
 588       procedure Insert_Sans_Hint is
 589         new Key_Ops.Generic_Conditional_Insert (Insert_Post);
 590
 591       --------------
 592       -- New_Node --
 593       --------------
 594
 595       function New_Node return Node_Access is
 596          procedure Initialize (Node : in out Node_Type);
 597          procedure Allocate_Node is new Generic_Allocate (Initialize);
 598
 599          procedure Initialize (Node : in out Node_Type) is
 600          begin
 601             Node.Key := Key;
 602             Node.Element := New_Item;
 603          end Initialize;
 604
 605          X : Node_Access;
 606
 607       begin
 608          Allocate_Node (Container, X);
 609          return X;
 610       end New_Node;
 611
 612    --  Start of processing for Insert
 613
 614    begin
 615       Insert_Sans_Hint
 616         (Container,
 617          Key,
 618          Position.Node,
 619          Inserted);
 620    end Insert;
 621
 622    procedure Insert
 623      (Container : in out Map;
 624       Key       : Key_Type;
 625       New_Item  : Element_Type)
 626    is
 627       Position : Cursor;
 628       Inserted : Boolean;
 629
 630    begin
 631       Insert (Container, Key, New_Item, Position, Inserted);
 632
 633       if not Inserted then
 634          raise Constraint_Error with "key already in map";
 635       end if;
 636    end Insert;
 637
 638    ------------
 639    -- Insert --
 640    ------------
 641
 642    procedure Insert
 643      (Container : in out Map;
 644       Key       : Key_Type;
 645       Position  : out Cursor;
 646       Inserted  : out Boolean)
 647    is
 648       function New_Node return Node_Access;
 649
 650       procedure Insert_Post is
 651         new Key_Ops.Generic_Insert_Post (New_Node);
 652
 653       procedure Insert_Sans_Hint is
 654         new Key_Ops.Generic_Conditional_Insert (Insert_Post);
 655
 656       --------------
 657       -- New_Node --
 658       --------------
 659
 660       function New_Node return Node_Access is
 661          procedure Initialize (Node : in out Node_Type);
 662          procedure Allocate_Node is new Generic_Allocate (Initialize);
 663
 664          ----------------
 665          -- Initialize --
 666          ----------------
 667
 668          procedure Initialize (Node : in out Node_Type) is
 669          begin
 670             Node.Key := Key;
 671          end Initialize;
 672
 673          X : Node_Access;
 674
 675       --  Start of processing for New_Node
 676
 677       begin
 678          Allocate_Node (Container, X);
 679          return X;
 680       end New_Node;
 681
 682    --  Start of processing for Insert
 683
 684    begin
 685       Insert_Sans_Hint (Container, Key, Position.Node, Inserted);
 686    end Insert;
 687
 688    --------------
 689    -- Is_Empty --
 690    --------------
 691
 692    function Is_Empty (Container : Map) return Boolean is
 693    begin
 694       return Length (Container) = 0;
 695    end Is_Empty;
 696
 697    -------------------------
 698    -- Is_Greater_Key_Node --
 699    -------------------------
 700
 701    function Is_Greater_Key_Node
 702      (Left  : Key_Type;
 703       Right : Node_Type) return Boolean
 704    is
 705    begin
 706       --  k > node same as node < k
 707
 708       return Right.Key < Left;
 709    end Is_Greater_Key_Node;
 710
 711    ----------------------
 712    -- Is_Less_Key_Node --
 713    ----------------------
 714
 715    function Is_Less_Key_Node
 716      (Left  : Key_Type;
 717       Right : Node_Type) return Boolean
 718    is
 719    begin
 720       return Left < Right.Key;
 721    end Is_Less_Key_Node;
 722
 723    -------------
 724    -- Iterate --
 725    -------------
 726
 727    procedure Iterate
 728      (Container : Map;
 729       Process   :
 730         not null access procedure (Container : Map; Position : Cursor))
 731    is
 732       procedure Process_Node (Node : Node_Access);
 733       pragma Inline (Process_Node);
 734
 735       procedure Local_Iterate is
 736         new Tree_Operations.Generic_Iteration (Process_Node);
 737
 738       ------------------
 739       -- Process_Node --
 740       ------------------
 741
 742       procedure Process_Node (Node : Node_Access) is
 743       begin
 744          Process (Container, (Node => Node));
 745       end Process_Node;
 746
 747       B : Natural renames Container'Unrestricted_Access.Busy;
 748
 749       --  Start of processing for Iterate
 750
 751    begin
 752       B := B + 1;
 753
 754       begin
 755          Local_Iterate (Container);
 756       exception
 757          when others =>
 758             B := B - 1;
 759             raise;
 760       end;
 761
 762       B := B - 1;
 763    end Iterate;
 764
 765    ---------
 766    -- Key --
 767    ---------
 768
 769    function Key (Container : Map; Position : Cursor) return Key_Type is
 770    begin
 771       if not Has_Element (Container, Position) then
 772          raise Constraint_Error with
 773            "Position cursor of function Key has no element";
 774       end if;
 775
 776       pragma Assert (Vet (Container, Position.Node),
 777                      "Position cursor of function Key is bad");
 778
 779       return Container.Nodes (Position.Node).Key;
 780    end Key;
 781
 782    ----------
 783    -- Last --
 784    ----------
 785
 786    function Last (Container : Map) return Cursor is
 787    begin
 788       if Length (Container) = 0 then
 789          return No_Element;
 790       end if;
 791
 792       return (Node => Container.Last);
 793    end Last;
 794
 795    ------------------
 796    -- Last_Element --
 797    ------------------
 798
 799    function Last_Element (Container : Map) return Element_Type is
 800    begin
 801       if Is_Empty (Container) then
 802          raise Constraint_Error with "map is empty";
 803       end if;
 804
 805       return Container.Nodes (Last (Container).Node).Element;
 806    end Last_Element;
 807
 808    --------------
 809    -- Last_Key --
 810    --------------
 811
 812    function Last_Key (Container : Map) return Key_Type is
 813    begin
 814       if Is_Empty (Container) then
 815          raise Constraint_Error with "map is empty";
 816       end if;
 817
 818       return Container.Nodes (Last (Container).Node).Key;
 819    end Last_Key;
 820
 821    ----------
 822    -- Left --
 823    ----------
 824
 825    function Left (Container : Map; Position : Cursor) return Map is
 826       Curs : Cursor := Position;
 827       C    : Map (Container.Capacity) := Copy (Container, Container.Capacity);
 828       Node : Count_Type;
 829
 830    begin
 831       if Curs = No_Element then
 832          return C;
 833       end if;
 834
 835       if not Has_Element (Container, Curs) then
 836          raise Constraint_Error;
 837       end if;
 838
 839       while Curs.Node /= 0 loop
 840          Node := Curs.Node;
 841          Delete (C, Curs);
 842          Curs := Next (Container, (Node => Node));
 843       end loop;
 844
 845       return C;
 846    end Left;
 847
 848    --------------
 849    -- Left_Son --
 850    --------------
 851
 852    function Left_Son (Node : Node_Type) return Count_Type is
 853    begin
 854       return Node.Left;
 855    end Left_Son;
 856
 857    ------------
 858    -- Length --
 859    ------------
 860
 861    function Length (Container : Map) return Count_Type is
 862    begin
 863       return Container.Length;
 864    end Length;
 865
 866    ----------
 867    -- Move --
 868    ----------
 869
 870    procedure Move (Target : in out Map; Source : in out Map) is
 871       NN : Tree_Types.Nodes_Type renames Source.Nodes;
 872       X  : Node_Access;
 873
 874    begin
 875       if Target'Address = Source'Address then
 876          return;
 877       end if;
 878
 879       if Target.Capacity < Length (Source) then
 880          raise Constraint_Error with  -- ???
 881            "Source length exceeds Target capacity";
 882       end if;
 883
 884       if Source.Busy > 0 then
 885          raise Program_Error with
 886            "attempt to tamper with cursors of Source (list is busy)";
 887       end if;
 888
 889       Clear (Target);
 890
 891       loop
 892          X := First (Source).Node;
 893          exit when X = 0;
 894
 895          --  Here we insert a copy of the source element into the target, and
 896          --  then delete the element from the source. Another possibility is
 897          --  that delete it first (and hang onto its index), then insert it.
 898          --  ???
 899
 900          Insert (Target, NN (X).Key, NN (X).Element);  -- optimize???
 901
 902          Tree_Operations.Delete_Node_Sans_Free (Source, X);
 903          Formal_Ordered_Maps.Free (Source, X);
 904       end loop;
 905    end Move;
 906
 907    ----------
 908    -- Next --
 909    ----------
 910
 911    procedure Next (Container : Map; Position : in out Cursor) is
 912    begin
 913       Position := Next (Container, Position);
 914    end Next;
 915
 916    function Next (Container : Map; Position : Cursor) return Cursor is
 917    begin
 918       if Position = No_Element then
 919          return No_Element;
 920       end if;
 921
 922       if not Has_Element (Container, Position) then
 923          raise Constraint_Error;
 924       end if;
 925
 926       pragma Assert (Vet (Container, Position.Node),
 927                      "bad cursor in Next");
 928
 929       return (Node => Tree_Operations.Next (Container, Position.Node));
 930    end Next;
 931
 932    -------------
 933    -- Overlap --
 934    -------------
 935
 936    function Overlap (Left, Right : Map) return Boolean is
 937    begin
 938       if Length (Left) = 0 or Length (Right) = 0 then
 939          return False;
 940       end if;
 941
 942       declare
 943          L_Node : Count_Type          := First (Left).Node;
 944          R_Node : Count_Type          := First (Right).Node;
 945          L_Last : constant Count_Type := Next (Left, Last (Left).Node);
 946          R_Last : constant Count_Type := Next (Right, Last (Right).Node);
 947
 948       begin
 949          if Left'Address = Right'Address then
 950             return True;
 951          end if;
 952
 953          loop
 954             if L_Node = L_Last
 955               or else R_Node = R_Last
 956             then
 957                return False;
 958             end if;
 959
 960             if Left.Nodes (L_Node).Key < Right.Nodes (R_Node).Key then
 961                L_Node := Next (Left, L_Node);
 962
 963             elsif Right.Nodes (R_Node).Key < Left.Nodes (L_Node).Key then
 964                R_Node := Next (Right, R_Node);
 965
 966             else
 967                return True;
 968             end if;
 969          end loop;
 970       end;
 971    end Overlap;
 972
 973    ------------
 974    -- Parent --
 975    ------------
 976
 977    function Parent (Node : Node_Type) return Count_Type is
 978    begin
 979       return Node.Parent;
 980    end Parent;
 981
 982    --------------
 983    -- Previous --
 984    --------------
 985
 986    procedure Previous (Container : Map; Position : in out Cursor) is
 987    begin
 988       Position := Previous (Container, Position);
 989    end Previous;
 990
 991    function Previous (Container : Map; Position : Cursor) return Cursor is
 992    begin
 993       if Position = No_Element then
 994          return No_Element;
 995       end if;
 996
 997       if not Has_Element (Container, Position) then
 998          raise Constraint_Error;
 999       end if;
1000
1001       pragma Assert (Vet (Container, Position.Node),
1002                      "bad cursor in Previous");
1003
1004       declare
1005          Node : constant Count_Type :=
1006                   Tree_Operations.Previous (Container, Position.Node);
1007
1008       begin
1009          if Node = 0 then
1010             return No_Element;
1011          end if;
1012
1013          return (Node => Node);
1014       end;
1015    end Previous;
1016
1017    -------------------
1018    -- Query_Element --
1019    -------------------
1020
1021    procedure Query_Element
1022      (Container : in out Map;
1023       Position  : Cursor;
1024       Process   : not null access procedure (Key     : Key_Type;
1025                                              Element : Element_Type))
1026    is
1027    begin
1028
1029       if not Has_Element (Container, Position) then
1030          raise Constraint_Error with
1031            "Position cursor of Query_Element has no element";
1032       end if;
1033
1034       pragma Assert (Vet (Container, Position.Node),
1035                      "Position cursor of Query_Element is bad");
1036
1037       declare
1038          B : Natural renames Container.Busy;
1039          L : Natural renames Container.Lock;
1040
1041       begin
1042          B := B + 1;
1043          L := L + 1;
1044
1045          declare
1046             N  : Node_Type renames Container.Nodes (Position.Node);
1047             K  : Key_Type renames N.Key;
1048             E  : Element_Type renames N.Element;
1049
1050          begin
1051             Process (K, E);
1052          exception
1053             when others =>
1054                L := L - 1;
1055                B := B - 1;
1056                raise;
1057          end;
1058
1059          L := L - 1;
1060          B := B - 1;
1061       end;
1062    end Query_Element;
1063
1064    ----------
1065    -- Read --
1066    ----------
1067
1068    procedure Read
1069      (Stream    : not null access Root_Stream_Type'Class;
1070       Container : out Map)
1071    is
1072       procedure Read_Element (Node : in out Node_Type);
1073       pragma Inline (Read_Element);
1074
1075       procedure Allocate is
1076          new Generic_Allocate (Read_Element);
1077
1078       procedure Read_Elements is
1079          new Tree_Operations.Generic_Read (Allocate);
1080
1081       ------------------
1082       -- Read_Element --
1083       ------------------
1084
1085       procedure Read_Element (Node : in out Node_Type) is
1086       begin
1087          Key_Type'Read (Stream, Node.Key);
1088          Element_Type'Read (Stream, Node.Element);
1089       end Read_Element;
1090
1091    --  Start of processing for Read
1092
1093    begin
1094       Read_Elements (Stream, Container);
1095    end Read;
1096
1097    procedure Read
1098      (Stream : not null access Root_Stream_Type'Class;
1099       Item   : out Cursor)
1100    is
1101    begin
1102       raise Program_Error with "attempt to stream map cursor";
1103    end Read;
1104
1105    -------------
1106    -- Replace --
1107    -------------
1108
1109    procedure Replace
1110      (Container : in out Map;
1111       Key       : Key_Type;
1112       New_Item  : Element_Type)
1113    is
1114    begin
1115       declare
1116          Node : constant Node_Access := Key_Ops.Find (Container, Key);
1117
1118       begin
1119          if Node = 0 then
1120             raise Constraint_Error with "key not in map";
1121          end if;
1122
1123          if Container.Lock > 0 then
1124             raise Program_Error with
1125               "attempt to tamper with cursors (map is locked)";
1126          end if;
1127
1128          declare
1129             N : Node_Type renames Container.Nodes (Node);
1130          begin
1131             N.Key := Key;
1132             N.Element := New_Item;
1133          end;
1134       end;
1135    end Replace;
1136
1137    ---------------------
1138    -- Replace_Element --
1139    ---------------------
1140
1141    procedure Replace_Element
1142      (Container : in out Map;
1143       Position  : Cursor;
1144       New_Item  : Element_Type)
1145    is
1146    begin
1147       if not Has_Element (Container, Position) then
1148          raise Constraint_Error with
1149            "Position cursor of Replace_Element has no element";
1150       end if;
1151
1152       if Container.Lock > 0 then
1153          raise Program_Error with
1154            "attempt to tamper with cursors (map is locked)";
1155       end if;
1156
1157       pragma Assert (Vet (Container, Position.Node),
1158                      "Position cursor of Replace_Element is bad");
1159
1160       Container.Nodes (Position.Node).Element := New_Item;
1161    end Replace_Element;
1162
1163    ---------------------
1164    -- Reverse_Iterate --
1165    ---------------------
1166
1167    procedure Reverse_Iterate
1168      (Container : Map;
1169       Process   : not null access procedure (Container : Map;
1170                                              Position : Cursor))
1171    is
1172       procedure Process_Node (Node : Node_Access);
1173       pragma Inline (Process_Node);
1174
1175       procedure Local_Reverse_Iterate is
1176         new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1177
1178       ------------------
1179       -- Process_Node --
1180       ------------------
1181
1182       procedure Process_Node (Node : Node_Access) is
1183       begin
1184          Process (Container, (Node => Node));
1185       end Process_Node;
1186
1187       B : Natural renames Container'Unrestricted_Access.Busy;
1188
1189    --  Start of processing for Reverse_Iterate
1190
1191    begin
1192       B := B + 1;
1193
1194       begin
1195          Local_Reverse_Iterate (Container);
1196       exception
1197          when others =>
1198             B := B - 1;
1199             raise;
1200       end;
1201
1202       B := B - 1;
1203    end Reverse_Iterate;
1204
1205    -----------
1206    -- Right --
1207    -----------
1208
1209    function Right (Container : Map; Position : Cursor) return Map is
1210       Curs : Cursor := First (Container);
1211       C    : Map (Container.Capacity) := Copy (Container, Container.Capacity);
1212       Node : Count_Type;
1213
1214    begin
1215       if Curs = No_Element then
1216          Clear (C);
1217          return C;
1218
1219       end if;
1220       if Position /= No_Element and not Has_Element (Container, Position) then
1221          raise Constraint_Error;
1222       end if;
1223
1224       while Curs.Node /= Position.Node loop
1225          Node := Curs.Node;
1226          Delete (C, Curs);
1227          Curs := Next (Container, (Node => Node));
1228       end loop;
1229
1230       return C;
1231    end Right;
1232
1233    ---------------
1234    -- Right_Son --
1235    ---------------
1236
1237    function Right_Son (Node : Node_Type) return Count_Type is
1238    begin
1239       return Node.Right;
1240    end Right_Son;
1241
1242    ---------------
1243    -- Set_Color --
1244    ---------------
1245
1246    procedure Set_Color (Node  : in out Node_Type; Color : Color_Type) is
1247    begin
1248       Node.Color := Color;
1249    end Set_Color;
1250
1251    --------------
1252    -- Set_Left --
1253    --------------
1254
1255    procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
1256    begin
1257       Node.Left := Left;
1258    end Set_Left;
1259
1260    ----------------
1261    -- Set_Parent --
1262    ----------------
1263
1264    procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
1265    begin
1266       Node.Parent := Parent;
1267    end Set_Parent;
1268
1269    ---------------
1270    -- Set_Right --
1271    ---------------
1272
1273    procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
1274    begin
1275       Node.Right := Right;
1276    end Set_Right;
1277
1278    ------------------
1279    -- Strict_Equal --
1280    ------------------
1281
1282    function Strict_Equal (Left, Right : Map) return Boolean is
1283       LNode : Count_Type := First (Left).Node;
1284       RNode : Count_Type := First (Right).Node;
1285
1286    begin
1287       if Length (Left) /= Length (Right) then
1288          return False;
1289       end if;
1290
1291       while LNode = RNode loop
1292          if LNode = 0 then
1293             return True;
1294          end if;
1295
1296          if Left.Nodes (LNode).Element /= Right.Nodes (RNode).Element
1297            or else Left.Nodes (LNode).Key /= Right.Nodes (RNode).Key
1298          then
1299             exit;
1300          end if;
1301
1302          LNode := Next (Left, LNode);
1303          RNode := Next (Right, RNode);
1304       end loop;
1305
1306       return False;
1307    end Strict_Equal;
1308
1309    --------------------
1310    -- Update_Element --
1311    --------------------
1312
1313    procedure Update_Element
1314      (Container : in out Map;
1315       Position  : Cursor;
1316       Process   : not null access procedure (Key     : Key_Type;
1317                                              Element : in out Element_Type))
1318    is
1319    begin
1320       if not Has_Element (Container, Position) then
1321          raise Constraint_Error with
1322            "Position cursor of Update_Element has no element";
1323       end if;
1324
1325       pragma Assert (Vet (Container, Position.Node),
1326                      "Position cursor of Update_Element is bad");
1327
1328       declare
1329          B : Natural renames Container.Busy;
1330          L : Natural renames Container.Lock;
1331
1332       begin
1333          B := B + 1;
1334          L := L + 1;
1335
1336          declare
1337             N : Node_Type renames Container.Nodes (Position.Node);
1338             K : Key_Type renames N.Key;
1339             E : Element_Type renames N.Element;
1340
1341          begin
1342             Process (K, E);
1343          exception
1344             when others =>
1345                L := L - 1;
1346                B := B - 1;
1347                raise;
1348          end;
1349
1350          L := L - 1;
1351          B := B - 1;
1352       end;
1353    end Update_Element;
1354
1355    -----------
1356    -- Write --
1357    -----------
1358
1359    procedure Write
1360      (Stream    : not null access Root_Stream_Type'Class;
1361       Container : Map)
1362    is
1363       procedure Write_Node
1364         (Stream : not null access Root_Stream_Type'Class;
1365          Node   : Node_Type);
1366       pragma Inline (Write_Node);
1367
1368       procedure Write_Nodes is
1369          new Tree_Operations.Generic_Write (Write_Node);
1370
1371       ----------------
1372       -- Write_Node --
1373       ----------------
1374
1375       procedure Write_Node
1376         (Stream : not null access Root_Stream_Type'Class;
1377          Node   : Node_Type)
1378       is
1379       begin
1380          Key_Type'Write (Stream, Node.Key);
1381          Element_Type'Write (Stream, Node.Element);
1382       end Write_Node;
1383
1384    --  Start of processing for Write
1385
1386    begin
1387       Write_Nodes (Stream, Container);
1388    end Write;
1389
1390    procedure Write
1391      (Stream : not null access Root_Stream_Type'Class;
1392       Item   : Cursor)
1393    is
1394    begin
1395       raise Program_Error with "attempt to stream map cursor";
1396    end Write;
1397
1398 end Ada.Containers.Formal_Ordered_Maps;