gcc/ada/a-coorma.adb

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