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