gcc/ada/a-coorma.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --           A D A . C O N T A I N E R S . O R D E R E D _ M A P S          --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2009, 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 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with Ada.Unchecked_Deallocation;
  31
  32 with Ada.Containers.Red_Black_Trees.Generic_Operations;
  33 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
  34
  35 with Ada.Containers.Red_Black_Trees.Generic_Keys;
  36 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
  37
  38 package body Ada.Containers.Ordered_Maps is
  39
  40    -----------------------------
  41    -- Node Access Subprograms --
  42    -----------------------------
  43
  44    --  These subprograms provide a functional interface to access fields
  45    --  of a node, and a procedural interface for modifying these values.
  46
  47    function Color (Node : Node_Access) return Color_Type;
  48    pragma Inline (Color);
  49
  50    function Left (Node : Node_Access) return Node_Access;
  51    pragma Inline (Left);
  52
  53    function Parent (Node : Node_Access) return Node_Access;
  54    pragma Inline (Parent);
  55
  56    function Right (Node : Node_Access) return Node_Access;
  57    pragma Inline (Right);
  58
  59    procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
  60    pragma Inline (Set_Parent);
  61
  62    procedure Set_Left (Node : Node_Access; Left : Node_Access);
  63    pragma Inline (Set_Left);
  64
  65    procedure Set_Right (Node : Node_Access; Right : Node_Access);
  66    pragma Inline (Set_Right);
  67
  68    procedure Set_Color (Node : Node_Access; Color : Color_Type);
  69    pragma Inline (Set_Color);
  70
  71    -----------------------
  72    -- Local Subprograms --
  73    -----------------------
  74
  75    function Copy_Node (Source : Node_Access) return Node_Access;
  76    pragma Inline (Copy_Node);
  77
  78    procedure Free (X : in out Node_Access);
  79
  80    function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
  81    pragma Inline (Is_Equal_Node_Node);
  82
  83    function Is_Greater_Key_Node
  84      (Left  : Key_Type;
  85       Right : Node_Access) return Boolean;
  86    pragma Inline (Is_Greater_Key_Node);
  87
  88    function Is_Less_Key_Node
  89      (Left  : Key_Type;
  90       Right : Node_Access) return Boolean;
  91    pragma Inline (Is_Less_Key_Node);
  92
  93    --------------------------
  94    -- Local Instantiations --
  95    --------------------------
  96
  97    package Tree_Operations is
  98       new Red_Black_Trees.Generic_Operations (Tree_Types);
  99
 100    procedure Delete_Tree is
 101       new Tree_Operations.Generic_Delete_Tree (Free);
 102
 103    function Copy_Tree is
 104       new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
 105
 106    use Tree_Operations;
 107
 108    package Key_Ops is
 109      new Red_Black_Trees.Generic_Keys
 110        (Tree_Operations     => Tree_Operations,
 111         Key_Type            => Key_Type,
 112         Is_Less_Key_Node    => Is_Less_Key_Node,
 113         Is_Greater_Key_Node => Is_Greater_Key_Node);
 114
 115    function Is_Equal is
 116      new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
 117
 118    ---------
 119    -- "<" --
 120    ---------
 121
 122    function "<" (Left, Right : Cursor) return Boolean is
 123    begin
 124       if Left.Node = null then
 125          raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
 126       end if;
 127
 128       if Right.Node = null then
 129          raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
 130       end if;
 131
 132       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 133                      "Left cursor of ""<"" is bad");
 134
 135       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 136                      "Right cursor of ""<"" is bad");
 137
 138       return Left.Node.Key < Right.Node.Key;
 139    end "<";
 140
 141    function "<" (Left : Cursor; Right : Key_Type) return Boolean is
 142    begin
 143       if Left.Node = null then
 144          raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
 145       end if;
 146
 147       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 148                      "Left cursor of ""<"" is bad");
 149
 150       return Left.Node.Key < Right;
 151    end "<";
 152
 153    function "<" (Left : Key_Type; Right : Cursor) return Boolean is
 154    begin
 155       if Right.Node = null then
 156          raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
 157       end if;
 158
 159       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 160                      "Right cursor of ""<"" is bad");
 161
 162       return Left < Right.Node.Key;
 163    end "<";
 164
 165    ---------
 166    -- "=" --
 167    ---------
 168
 169    function "=" (Left, Right : Map) return Boolean is
 170    begin
 171       return Is_Equal (Left.Tree, Right.Tree);
 172    end "=";
 173
 174    ---------
 175    -- ">" --
 176    ---------
 177
 178    function ">" (Left, Right : Cursor) return Boolean is
 179    begin
 180       if Left.Node = null then
 181          raise Constraint_Error with "Left cursor of "">"" equals No_Element";
 182       end if;
 183
 184       if Right.Node = null then
 185          raise Constraint_Error with "Right cursor of "">"" equals No_Element";
 186       end if;
 187
 188       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 189                      "Left cursor of "">"" is bad");
 190
 191       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 192                      "Right cursor of "">"" is bad");
 193
 194       return Right.Node.Key < Left.Node.Key;
 195    end ">";
 196
 197    function ">" (Left : Cursor; Right : Key_Type) return Boolean is
 198    begin
 199       if Left.Node = null then
 200          raise Constraint_Error with "Left cursor of "">"" equals No_Element";
 201       end if;
 202
 203       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 204                      "Left cursor of "">"" is bad");
 205
 206       return Right < Left.Node.Key;
 207    end ">";
 208
 209    function ">" (Left : Key_Type; Right : Cursor) return Boolean is
 210    begin
 211       if Right.Node = null then
 212          raise Constraint_Error with "Right cursor of "">"" equals No_Element";
 213       end if;
 214
 215       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 216                      "Right cursor of "">"" is bad");
 217
 218       return Right.Node.Key < Left;
 219    end ">";
 220
 221    ------------
 222    -- Adjust --
 223    ------------
 224
 225    procedure Adjust is
 226       new Tree_Operations.Generic_Adjust (Copy_Tree);
 227
 228    procedure Adjust (Container : in out Map) is
 229    begin
 230       Adjust (Container.Tree);
 231    end Adjust;
 232
 233    -------------
 234    -- Ceiling --
 235    -------------
 236
 237    function Ceiling (Container : Map; Key : Key_Type) return Cursor is
 238       Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
 239
 240    begin
 241       if Node = null then
 242          return No_Element;
 243       end if;
 244
 245       return Cursor'(Container'Unrestricted_Access, Node);
 246    end Ceiling;
 247
 248    -----------
 249    -- Clear --
 250    -----------
 251
 252    procedure Clear is
 253       new Tree_Operations.Generic_Clear (Delete_Tree);
 254
 255    procedure Clear (Container : in out Map) is
 256    begin
 257       Clear (Container.Tree);
 258    end Clear;
 259
 260    -----------
 261    -- Color --
 262    -----------
 263
 264    function Color (Node : Node_Access) return Color_Type is
 265    begin
 266       return Node.Color;
 267    end Color;
 268
 269    --------------
 270    -- Contains --
 271    --------------
 272
 273    function Contains (Container : Map; Key : Key_Type) return Boolean is
 274    begin
 275       return Find (Container, Key) /= No_Element;
 276    end Contains;
 277
 278    ---------------
 279    -- Copy_Node --
 280    ---------------
 281
 282    function Copy_Node (Source : Node_Access) return Node_Access is
 283       Target : constant Node_Access :=
 284                  new Node_Type'(Color   => Source.Color,
 285                                 Key     => Source.Key,
 286                                 Element => Source.Element,
 287                                 Parent  => null,
 288                                 Left    => null,
 289                                 Right   => null);
 290    begin
 291       return Target;
 292    end Copy_Node;
 293
 294    ------------
 295    -- Delete --
 296    ------------
 297
 298    procedure Delete (Container : in out Map; Position : in out Cursor) is
 299       Tree : Tree_Type renames Container.Tree;
 300
 301    begin
 302       if Position.Node = null then
 303          raise Constraint_Error with
 304            "Position cursor of Delete equals No_Element";
 305       end if;
 306
 307       if Position.Container /= Container'Unrestricted_Access then
 308          raise Program_Error with
 309            "Position cursor of Delete designates wrong map";
 310       end if;
 311
 312       pragma Assert (Vet (Tree, Position.Node),
 313                      "Position cursor of Delete is bad");
 314
 315       Tree_Operations.Delete_Node_Sans_Free (Tree, Position.Node);
 316       Free (Position.Node);
 317
 318       Position.Container := null;
 319    end Delete;
 320
 321    procedure Delete (Container : in out Map; Key : Key_Type) is
 322       X : Node_Access := Key_Ops.Find (Container.Tree, Key);
 323
 324    begin
 325       if X = null then
 326          raise Constraint_Error with "key not in map";
 327       end if;
 328
 329       Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 330       Free (X);
 331    end Delete;
 332
 333    ------------------
 334    -- Delete_First --
 335    ------------------
 336
 337    procedure Delete_First (Container : in out Map) is
 338       X : Node_Access := Container.Tree.First;
 339
 340    begin
 341       if X /= null then
 342          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 343          Free (X);
 344       end if;
 345    end Delete_First;
 346
 347    -----------------
 348    -- Delete_Last --
 349    -----------------
 350
 351    procedure Delete_Last (Container : in out Map) is
 352       X : Node_Access := Container.Tree.Last;
 353
 354    begin
 355       if X /= null then
 356          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 357          Free (X);
 358       end if;
 359    end Delete_Last;
 360
 361    -------------
 362    -- Element --
 363    -------------
 364
 365    function Element (Position : Cursor) return Element_Type is
 366    begin
 367       if Position.Node = null then
 368          raise Constraint_Error with
 369            "Position cursor of function Element equals No_Element";
 370       end if;
 371
 372       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 373                      "Position cursor of function Element is bad");
 374
 375       return Position.Node.Element;
 376    end Element;
 377
 378    function Element (Container : Map; Key : Key_Type) return Element_Type is
 379       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
 380
 381    begin
 382       if Node = null then
 383          raise Constraint_Error with "key not in map";
 384       end if;
 385
 386       return Node.Element;
 387    end Element;
 388
 389    ---------------------
 390    -- Equivalent_Keys --
 391    ---------------------
 392
 393    function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
 394    begin
 395       if Left < Right
 396         or else Right < Left
 397       then
 398          return False;
 399       else
 400          return True;
 401       end if;
 402    end Equivalent_Keys;
 403
 404    -------------
 405    -- Exclude --
 406    -------------
 407
 408    procedure Exclude (Container : in out Map; Key : Key_Type) is
 409       X : Node_Access := Key_Ops.Find (Container.Tree, Key);
 410
 411    begin
 412       if X /= null then
 413          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 414          Free (X);
 415       end if;
 416    end Exclude;
 417
 418    ----------
 419    -- Find --
 420    ----------
 421
 422    function Find (Container : Map; Key : Key_Type) return Cursor is
 423       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
 424
 425    begin
 426       if Node = null then
 427          return No_Element;
 428       end if;
 429
 430       return Cursor'(Container'Unrestricted_Access, Node);
 431    end Find;
 432
 433    -----------
 434    -- First --
 435    -----------
 436
 437    function First (Container : Map) return Cursor is
 438       T : Tree_Type renames Container.Tree;
 439
 440    begin
 441       if T.First = null then
 442          return No_Element;
 443       end if;
 444
 445       return Cursor'(Container'Unrestricted_Access, T.First);
 446    end First;
 447
 448    -------------------
 449    -- First_Element --
 450    -------------------
 451
 452    function First_Element (Container : Map) return Element_Type is
 453       T : Tree_Type renames Container.Tree;
 454
 455    begin
 456       if T.First = null then
 457          raise Constraint_Error with "map is empty";
 458       end if;
 459
 460       return T.First.Element;
 461    end First_Element;
 462
 463    ---------------
 464    -- First_Key --
 465    ---------------
 466
 467    function First_Key (Container : Map) return Key_Type is
 468       T : Tree_Type renames Container.Tree;
 469
 470    begin
 471       if T.First = null then
 472          raise Constraint_Error with "map is empty";
 473       end if;
 474
 475       return T.First.Key;
 476    end First_Key;
 477
 478    -----------
 479    -- Floor --
 480    -----------
 481
 482    function Floor (Container : Map; Key : Key_Type) return Cursor is
 483       Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
 484
 485    begin
 486       if Node = null then
 487          return No_Element;
 488       end if;
 489
 490       return Cursor'(Container'Unrestricted_Access, Node);
 491    end Floor;
 492
 493    ----------
 494    -- Free --
 495    ----------
 496
 497    procedure Free (X : in out Node_Access) is
 498       procedure Deallocate is
 499          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 500
 501    begin
 502       if X = null then
 503          return;
 504       end if;
 505
 506       X.Parent := X;
 507       X.Left := X;
 508       X.Right := X;
 509
 510       Deallocate (X);
 511    end Free;
 512
 513    -----------------
 514    -- Has_Element --
 515    -----------------
 516
 517    function Has_Element (Position : Cursor) return Boolean is
 518    begin
 519       return Position /= No_Element;
 520    end Has_Element;
 521
 522    -------------
 523    -- Include --
 524    -------------
 525
 526    procedure Include
 527      (Container : in out Map;
 528       Key       : Key_Type;
 529       New_Item  : Element_Type)
 530    is
 531       Position : Cursor;
 532       Inserted : Boolean;
 533
 534    begin
 535       Insert (Container, Key, New_Item, Position, Inserted);
 536
 537       if not Inserted then
 538          if Container.Tree.Lock > 0 then
 539             raise Program_Error with
 540               "attempt to tamper with cursors (map is locked)";
 541          end if;
 542
 543          Position.Node.Key := Key;
 544          Position.Node.Element := New_Item;
 545       end if;
 546    end Include;
 547
 548    ------------
 549    -- Insert --
 550    ------------
 551
 552    procedure Insert
 553      (Container : in out Map;
 554       Key       : Key_Type;
 555       New_Item  : Element_Type;
 556       Position  : out Cursor;
 557       Inserted  : out Boolean)
 558    is
 559       function New_Node return Node_Access;
 560       pragma Inline (New_Node);
 561
 562       procedure Insert_Post is
 563         new Key_Ops.Generic_Insert_Post (New_Node);
 564
 565       procedure Insert_Sans_Hint is
 566         new Key_Ops.Generic_Conditional_Insert (Insert_Post);
 567
 568       --------------
 569       -- New_Node --
 570       --------------
 571
 572       function New_Node return Node_Access is
 573       begin
 574          return new Node_Type'(Key     => Key,
 575                                Element => New_Item,
 576                                Color   => Red_Black_Trees.Red,
 577                                Parent  => null,
 578                                Left    => null,
 579                                Right   => null);
 580       end New_Node;
 581
 582    --  Start of processing for Insert
 583
 584    begin
 585       Insert_Sans_Hint
 586         (Container.Tree,
 587          Key,
 588          Position.Node,
 589          Inserted);
 590
 591       Position.Container := Container'Unrestricted_Access;
 592    end Insert;
 593
 594    procedure Insert
 595      (Container : in out Map;
 596       Key       : Key_Type;
 597       New_Item  : Element_Type)
 598    is
 599       Position : Cursor;
 600       pragma Unreferenced (Position);
 601
 602       Inserted : Boolean;
 603
 604    begin
 605       Insert (Container, Key, New_Item, Position, Inserted);
 606
 607       if not Inserted then
 608          raise Constraint_Error with "key already in map";
 609       end if;
 610    end Insert;
 611
 612    procedure Insert
 613      (Container : in out Map;
 614       Key       : Key_Type;
 615       Position  : out Cursor;
 616       Inserted  : out Boolean)
 617    is
 618       function New_Node return Node_Access;
 619       pragma Inline (New_Node);
 620
 621       procedure Insert_Post is
 622         new Key_Ops.Generic_Insert_Post (New_Node);
 623
 624       procedure Insert_Sans_Hint is
 625         new Key_Ops.Generic_Conditional_Insert (Insert_Post);
 626
 627       --------------
 628       -- New_Node --
 629       --------------
 630
 631       function New_Node return Node_Access is
 632       begin
 633          return new Node_Type'(Key     => Key,
 634                                Element => <>,
 635                                Color   => Red_Black_Trees.Red,
 636                                Parent  => null,
 637                                Left    => null,
 638                                Right   => null);
 639       end New_Node;
 640
 641    --  Start of processing for Insert
 642
 643    begin
 644       Insert_Sans_Hint
 645         (Container.Tree,
 646          Key,
 647          Position.Node,
 648          Inserted);
 649
 650       Position.Container := Container'Unrestricted_Access;
 651    end Insert;
 652
 653    --------------
 654    -- Is_Empty --
 655    --------------
 656
 657    function Is_Empty (Container : Map) return Boolean is
 658    begin
 659       return Container.Tree.Length = 0;
 660    end Is_Empty;
 661
 662    ------------------------
 663    -- Is_Equal_Node_Node --
 664    ------------------------
 665
 666    function Is_Equal_Node_Node
 667      (L, R : Node_Access) return Boolean is
 668    begin
 669       if L.Key < R.Key then
 670          return False;
 671
 672       elsif R.Key < L.Key then
 673          return False;
 674
 675       else
 676          return L.Element = R.Element;
 677       end if;
 678    end Is_Equal_Node_Node;
 679
 680    -------------------------
 681    -- Is_Greater_Key_Node --
 682    -------------------------
 683
 684    function Is_Greater_Key_Node
 685      (Left  : Key_Type;
 686       Right : Node_Access) return Boolean
 687    is
 688    begin
 689       --  k > node same as node < k
 690
 691       return Right.Key < Left;
 692    end Is_Greater_Key_Node;
 693
 694    ----------------------
 695    -- Is_Less_Key_Node --
 696    ----------------------
 697
 698    function Is_Less_Key_Node
 699      (Left  : Key_Type;
 700       Right : Node_Access) return Boolean
 701    is
 702    begin
 703       return Left < Right.Key;
 704    end Is_Less_Key_Node;
 705
 706    -------------
 707    -- Iterate --
 708    -------------
 709
 710    procedure Iterate
 711      (Container : Map;
 712       Process   : not null access procedure (Position : Cursor))
 713    is
 714       procedure Process_Node (Node : Node_Access);
 715       pragma Inline (Process_Node);
 716
 717       procedure Local_Iterate is
 718          new Tree_Operations.Generic_Iteration (Process_Node);
 719
 720       ------------------
 721       -- Process_Node --
 722       ------------------
 723
 724       procedure Process_Node (Node : Node_Access) is
 725       begin
 726          Process (Cursor'(Container'Unrestricted_Access, Node));
 727       end Process_Node;
 728
 729       B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
 730
 731    --  Start of processing for Iterate
 732
 733    begin
 734       B := B + 1;
 735
 736       begin
 737          Local_Iterate (Container.Tree);
 738       exception
 739          when others =>
 740             B := B - 1;
 741             raise;
 742       end;
 743
 744       B := B - 1;
 745    end Iterate;
 746
 747    ---------
 748    -- Key --
 749    ---------
 750
 751    function Key (Position : Cursor) return Key_Type is
 752    begin
 753       if Position.Node = null then
 754          raise Constraint_Error with
 755            "Position cursor of function Key equals No_Element";
 756       end if;
 757
 758       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 759                      "Position cursor of function Key is bad");
 760
 761       return Position.Node.Key;
 762    end Key;
 763
 764    ----------
 765    -- Last --
 766    ----------
 767
 768    function Last (Container : Map) return Cursor is
 769       T : Tree_Type renames Container.Tree;
 770
 771    begin
 772       if T.Last = null then
 773          return No_Element;
 774       end if;
 775
 776       return Cursor'(Container'Unrestricted_Access, T.Last);
 777    end Last;
 778
 779    ------------------
 780    -- Last_Element --
 781    ------------------
 782
 783    function Last_Element (Container : Map) return Element_Type is
 784       T : Tree_Type renames Container.Tree;
 785
 786    begin
 787       if T.Last = null then
 788          raise Constraint_Error with "map is empty";
 789       end if;
 790
 791       return T.Last.Element;
 792    end Last_Element;
 793
 794    --------------
 795    -- Last_Key --
 796    --------------
 797
 798    function Last_Key (Container : Map) return Key_Type is
 799       T : Tree_Type renames Container.Tree;
 800
 801    begin
 802       if T.Last = null then
 803          raise Constraint_Error with "map is empty";
 804       end if;
 805
 806       return T.Last.Key;
 807    end Last_Key;
 808
 809    ----------
 810    -- Left --
 811    ----------
 812
 813    function Left (Node : Node_Access) return Node_Access is
 814    begin
 815       return Node.Left;
 816    end Left;
 817
 818    ------------
 819    -- Length --
 820    ------------
 821
 822    function Length (Container : Map) return Count_Type is
 823    begin
 824       return Container.Tree.Length;
 825    end Length;
 826
 827    ----------
 828    -- Move --
 829    ----------
 830
 831    procedure Move is
 832       new Tree_Operations.Generic_Move (Clear);
 833
 834    procedure Move (Target : in out Map; Source : in out Map) is
 835    begin
 836       Move (Target => Target.Tree, Source => Source.Tree);
 837    end Move;
 838
 839    ----------
 840    -- Next --
 841    ----------
 842
 843    procedure Next (Position : in out Cursor) is
 844    begin
 845       Position := Next (Position);
 846    end Next;
 847
 848    function Next (Position : Cursor) return Cursor is
 849    begin
 850       if Position = No_Element then
 851          return No_Element;
 852       end if;
 853
 854       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 855                      "Position cursor of Next is bad");
 856
 857       declare
 858          Node : constant Node_Access :=
 859                   Tree_Operations.Next (Position.Node);
 860
 861       begin
 862          if Node = null then
 863             return No_Element;
 864          end if;
 865
 866          return Cursor'(Position.Container, Node);
 867       end;
 868    end Next;
 869
 870    ------------
 871    -- Parent --
 872    ------------
 873
 874    function Parent (Node : Node_Access) return Node_Access is
 875    begin
 876       return Node.Parent;
 877    end Parent;
 878
 879    --------------
 880    -- Previous --
 881    --------------
 882
 883    procedure Previous (Position : in out Cursor) is
 884    begin
 885       Position := Previous (Position);
 886    end Previous;
 887
 888    function Previous (Position : Cursor) return Cursor is
 889    begin
 890       if Position = No_Element then
 891          return No_Element;
 892       end if;
 893
 894       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 895                      "Position cursor of Previous is bad");
 896
 897       declare
 898          Node : constant Node_Access :=
 899                   Tree_Operations.Previous (Position.Node);
 900
 901       begin
 902          if Node = null then
 903             return No_Element;
 904          end if;
 905
 906          return Cursor'(Position.Container, Node);
 907       end;
 908    end Previous;
 909
 910    -------------------
 911    -- Query_Element --
 912    -------------------
 913
 914    procedure Query_Element
 915      (Position : Cursor;
 916       Process  : not null access procedure (Key     : Key_Type;
 917                                             Element : Element_Type))
 918    is
 919    begin
 920       if Position.Node = null then
 921          raise Constraint_Error with
 922            "Position cursor of Query_Element equals No_Element";
 923       end if;
 924
 925       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 926                      "Position cursor of Query_Element is bad");
 927
 928       declare
 929          T : Tree_Type renames Position.Container.Tree;
 930
 931          B : Natural renames T.Busy;
 932          L : Natural renames T.Lock;
 933
 934       begin
 935          B := B + 1;
 936          L := L + 1;
 937
 938          declare
 939             K : Key_Type renames Position.Node.Key;
 940             E : Element_Type renames Position.Node.Element;
 941
 942          begin
 943             Process (K, E);
 944          exception
 945             when others =>
 946                L := L - 1;
 947                B := B - 1;
 948                raise;
 949          end;
 950
 951          L := L - 1;
 952          B := B - 1;
 953       end;
 954    end Query_Element;
 955
 956    ----------
 957    -- Read --
 958    ----------
 959
 960    procedure Read
 961      (Stream    : not null access Root_Stream_Type'Class;
 962       Container : out Map)
 963    is
 964       function Read_Node
 965         (Stream : not null access Root_Stream_Type'Class) return Node_Access;
 966       pragma Inline (Read_Node);
 967
 968       procedure Read is
 969          new Tree_Operations.Generic_Read (Clear, Read_Node);
 970
 971       ---------------
 972       -- Read_Node --
 973       ---------------
 974
 975       function Read_Node
 976         (Stream : not null access Root_Stream_Type'Class) return Node_Access
 977       is
 978          Node : Node_Access := new Node_Type;
 979       begin
 980          Key_Type'Read (Stream, Node.Key);
 981          Element_Type'Read (Stream, Node.Element);
 982          return Node;
 983       exception
 984          when others =>
 985             Free (Node);
 986             raise;
 987       end Read_Node;
 988
 989    --  Start of processing for Read
 990
 991    begin
 992       Read (Stream, Container.Tree);
 993    end Read;
 994
 995    procedure Read
 996      (Stream : not null access Root_Stream_Type'Class;
 997       Item   : out Cursor)
 998    is
 999    begin
1000       raise Program_Error with "attempt to stream map cursor";
1001    end Read;
1002
1003    -------------
1004    -- Replace --
1005    -------------
1006
1007    procedure Replace
1008      (Container : in out Map;
1009       Key       : Key_Type;
1010       New_Item  : Element_Type)
1011    is
1012       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1013
1014    begin
1015       if Node = null then
1016          raise Constraint_Error with "key not in map";
1017       end if;
1018
1019       if Container.Tree.Lock > 0 then
1020          raise Program_Error with
1021            "attempt to tamper with cursors (map is locked)";
1022       end if;
1023
1024       Node.Key := Key;
1025       Node.Element := New_Item;
1026    end Replace;
1027
1028    ---------------------
1029    -- Replace_Element --
1030    ---------------------
1031
1032    procedure Replace_Element
1033      (Container : in out Map;
1034       Position  : Cursor;
1035       New_Item  : Element_Type)
1036    is
1037    begin
1038       if Position.Node = null then
1039          raise Constraint_Error with
1040            "Position cursor of Replace_Element equals No_Element";
1041       end if;
1042
1043       if Position.Container /= Container'Unrestricted_Access then
1044          raise Program_Error with
1045            "Position cursor of Replace_Element designates wrong map";
1046       end if;
1047
1048       if Container.Tree.Lock > 0 then
1049          raise Program_Error with
1050            "attempt to tamper with cursors (map is locked)";
1051       end if;
1052
1053       pragma Assert (Vet (Container.Tree, Position.Node),
1054                      "Position cursor of Replace_Element is bad");
1055
1056       Position.Node.Element := New_Item;
1057    end Replace_Element;
1058
1059    ---------------------
1060    -- Reverse_Iterate --
1061    ---------------------
1062
1063    procedure Reverse_Iterate
1064      (Container : Map;
1065       Process   : not null access procedure (Position : Cursor))
1066    is
1067       procedure Process_Node (Node : Node_Access);
1068       pragma Inline (Process_Node);
1069
1070       procedure Local_Reverse_Iterate is
1071          new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1072
1073       ------------------
1074       -- Process_Node --
1075       ------------------
1076
1077       procedure Process_Node (Node : Node_Access) is
1078       begin
1079          Process (Cursor'(Container'Unrestricted_Access, Node));
1080       end Process_Node;
1081
1082       B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
1083
1084       --  Start of processing for Reverse_Iterate
1085
1086    begin
1087       B := B + 1;
1088
1089       begin
1090          Local_Reverse_Iterate (Container.Tree);
1091       exception
1092          when others =>
1093             B := B - 1;
1094             raise;
1095       end;
1096
1097       B := B - 1;
1098    end Reverse_Iterate;
1099
1100    -----------
1101    -- Right --
1102    -----------
1103
1104    function Right (Node : Node_Access) return Node_Access is
1105    begin
1106       return Node.Right;
1107    end Right;
1108
1109    ---------------
1110    -- Set_Color --
1111    ---------------
1112
1113    procedure Set_Color
1114      (Node  : Node_Access;
1115       Color : Color_Type)
1116    is
1117    begin
1118       Node.Color := Color;
1119    end Set_Color;
1120
1121    --------------
1122    -- Set_Left --
1123    --------------
1124
1125    procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1126    begin
1127       Node.Left := Left;
1128    end Set_Left;
1129
1130    ----------------
1131    -- Set_Parent --
1132    ----------------
1133
1134    procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1135    begin
1136       Node.Parent := Parent;
1137    end Set_Parent;
1138
1139    ---------------
1140    -- Set_Right --
1141    ---------------
1142
1143    procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1144    begin
1145       Node.Right := Right;
1146    end Set_Right;
1147
1148    --------------------
1149    -- Update_Element --
1150    --------------------
1151
1152    procedure Update_Element
1153      (Container : in out Map;
1154       Position  : Cursor;
1155       Process   : not null access procedure (Key     : Key_Type;
1156                                              Element : in out Element_Type))
1157    is
1158    begin
1159       if Position.Node = null then
1160          raise Constraint_Error with
1161            "Position cursor of Update_Element equals No_Element";
1162       end if;
1163
1164       if Position.Container /= Container'Unrestricted_Access then
1165          raise Program_Error with
1166            "Position cursor of Update_Element designates wrong map";
1167       end if;
1168
1169       pragma Assert (Vet (Container.Tree, Position.Node),
1170                      "Position cursor of Update_Element is bad");
1171
1172       declare
1173          T : Tree_Type renames Container.Tree;
1174
1175          B : Natural renames T.Busy;
1176          L : Natural renames T.Lock;
1177
1178       begin
1179          B := B + 1;
1180          L := L + 1;
1181
1182          declare
1183             K : Key_Type renames Position.Node.Key;
1184             E : Element_Type renames Position.Node.Element;
1185
1186          begin
1187             Process (K, E);
1188
1189          exception
1190             when others =>
1191                L := L - 1;
1192                B := B - 1;
1193                raise;
1194          end;
1195
1196          L := L - 1;
1197          B := B - 1;
1198       end;
1199    end Update_Element;
1200
1201    -----------
1202    -- Write --
1203    -----------
1204
1205    procedure Write
1206      (Stream    : not null access Root_Stream_Type'Class;
1207       Container : Map)
1208    is
1209       procedure Write_Node
1210         (Stream : not null access Root_Stream_Type'Class;
1211          Node   : Node_Access);
1212       pragma Inline (Write_Node);
1213
1214       procedure Write is
1215          new Tree_Operations.Generic_Write (Write_Node);
1216
1217       ----------------
1218       -- Write_Node --
1219       ----------------
1220
1221       procedure Write_Node
1222         (Stream : not null access Root_Stream_Type'Class;
1223          Node   : Node_Access)
1224       is
1225       begin
1226          Key_Type'Write (Stream, Node.Key);
1227          Element_Type'Write (Stream, Node.Element);
1228       end Write_Node;
1229
1230    --  Start of processing for Write
1231
1232    begin
1233       Write (Stream, Container.Tree);
1234    end Write;
1235
1236    procedure Write
1237      (Stream : not null access Root_Stream_Type'Class;
1238       Item   : Cursor)
1239    is
1240    begin
1241       raise Program_Error with "attempt to stream map cursor";
1242    end Write;
1243
1244 end Ada.Containers.Ordered_Maps;