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