gcc/ada/a-ciorma.adb

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