gcc/ada/a-ciorma.adb

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