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-2006, 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       Inserted : Boolean;
 599
 600    begin
 601       Insert (Container, Key, New_Item, Position, Inserted);
 602
 603       if not Inserted then
 604          raise Constraint_Error with "key already in map";
 605       end if;
 606    end Insert;
 607
 608    ------------
 609    -- Insert --
 610    ------------
 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 : 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 : 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          exception
1189             when others =>
1190                L := L - 1;
1191                B := B - 1;
1192                raise;
1193          end;
1194
1195          L := L - 1;
1196          B := B - 1;
1197       end;
1198    end Update_Element;
1199
1200    -----------
1201    -- Write --
1202    -----------
1203
1204    procedure Write
1205      (Stream    : not null access Root_Stream_Type'Class;
1206       Container : Map)
1207    is
1208       procedure Write_Node
1209         (Stream : access Root_Stream_Type'Class;
1210          Node   : Node_Access);
1211       pragma Inline (Write_Node);
1212
1213       procedure Write is
1214          new Tree_Operations.Generic_Write (Write_Node);
1215
1216       ----------------
1217       -- Write_Node --
1218       ----------------
1219
1220       procedure Write_Node
1221         (Stream : access Root_Stream_Type'Class;
1222          Node   : Node_Access)
1223       is
1224       begin
1225          Key_Type'Write (Stream, Node.Key);
1226          Element_Type'Write (Stream, Node.Element);
1227       end Write_Node;
1228
1229    --  Start of processing for Write
1230
1231    begin
1232       Write (Stream, Container.Tree);
1233    end Write;
1234
1235    procedure Write
1236      (Stream : not null access Root_Stream_Type'Class;
1237       Item   : Cursor)
1238    is
1239    begin
1240       raise Program_Error with "attempt to stream map cursor";
1241    end Write;
1242
1243 end Ada.Containers.Ordered_Maps;