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-2013, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with Ada.Unchecked_Deallocation;
  31
  32 with Ada.Containers.Red_Black_Trees.Generic_Operations;
  33 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
  34
  35 with Ada.Containers.Red_Black_Trees.Generic_Keys;
  36 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
  37
  38 with System; use type System.Address;
  39
  40 package body Ada.Containers.Indefinite_Ordered_Maps is
  41    pragma Suppress (All_Checks);
  42
  43    -----------------------------
  44    -- Node Access Subprograms --
  45    -----------------------------
  46
  47    --  These subprograms provide a functional interface to access fields
  48    --  of a node, and a procedural interface for modifying these values.
  49
  50    function Color (Node : Node_Access) return Color_Type;
  51    pragma Inline (Color);
  52
  53    function Left (Node : Node_Access) return Node_Access;
  54    pragma Inline (Left);
  55
  56    function Parent (Node : Node_Access) return Node_Access;
  57    pragma Inline (Parent);
  58
  59    function Right (Node : Node_Access) return Node_Access;
  60    pragma Inline (Right);
  61
  62    procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
  63    pragma Inline (Set_Parent);
  64
  65    procedure Set_Left (Node : Node_Access; Left : Node_Access);
  66    pragma Inline (Set_Left);
  67
  68    procedure Set_Right (Node : Node_Access; Right : Node_Access);
  69    pragma Inline (Set_Right);
  70
  71    procedure Set_Color (Node : Node_Access; Color : Color_Type);
  72    pragma Inline (Set_Color);
  73
  74    -----------------------
  75    -- Local Subprograms --
  76    -----------------------
  77
  78    function Copy_Node (Source : Node_Access) return Node_Access;
  79    pragma Inline (Copy_Node);
  80
  81    procedure Free (X : in out Node_Access);
  82
  83    function Is_Equal_Node_Node
  84      (L, R : Node_Access) return Boolean;
  85    pragma Inline (Is_Equal_Node_Node);
  86
  87    function Is_Greater_Key_Node
  88      (Left  : Key_Type;
  89       Right : Node_Access) return Boolean;
  90    pragma Inline (Is_Greater_Key_Node);
  91
  92    function Is_Less_Key_Node
  93      (Left  : Key_Type;
  94       Right : Node_Access) return Boolean;
  95    pragma Inline (Is_Less_Key_Node);
  96
  97    --------------------------
  98    -- Local Instantiations --
  99    --------------------------
 100
 101    package Tree_Operations is
 102      new Red_Black_Trees.Generic_Operations (Tree_Types);
 103
 104    procedure Delete_Tree is
 105       new Tree_Operations.Generic_Delete_Tree (Free);
 106
 107    function Copy_Tree is
 108       new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
 109
 110    use Tree_Operations;
 111
 112    package Key_Ops is
 113      new Red_Black_Trees.Generic_Keys
 114        (Tree_Operations     => Tree_Operations,
 115         Key_Type            => Key_Type,
 116         Is_Less_Key_Node    => Is_Less_Key_Node,
 117         Is_Greater_Key_Node => Is_Greater_Key_Node);
 118
 119    procedure Free_Key is
 120      new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
 121
 122    procedure Free_Element is
 123      new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
 124
 125    function Is_Equal is
 126      new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
 127
 128    ---------
 129    -- "<" --
 130    ---------
 131
 132    function "<" (Left, Right : Cursor) return Boolean is
 133    begin
 134       if Left.Node = null then
 135          raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
 136       end if;
 137
 138       if Right.Node = null then
 139          raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
 140       end if;
 141
 142       if Left.Node.Key = null then
 143          raise Program_Error with "Left cursor in ""<"" is bad";
 144       end if;
 145
 146       if Right.Node.Key = null then
 147          raise Program_Error with "Right cursor in ""<"" is bad";
 148       end if;
 149
 150       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 151                      "Left cursor in ""<"" is bad");
 152
 153       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 154                      "Right cursor in ""<"" is bad");
 155
 156       return Left.Node.Key.all < Right.Node.Key.all;
 157    end "<";
 158
 159    function "<" (Left : Cursor; Right : Key_Type) return Boolean is
 160    begin
 161       if Left.Node = null then
 162          raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
 163       end if;
 164
 165       if Left.Node.Key = null then
 166          raise Program_Error with "Left cursor in ""<"" is bad";
 167       end if;
 168
 169       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 170                      "Left cursor in ""<"" is bad");
 171
 172       return Left.Node.Key.all < Right;
 173    end "<";
 174
 175    function "<" (Left : Key_Type; Right : Cursor) return Boolean is
 176    begin
 177       if Right.Node = null then
 178          raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
 179       end if;
 180
 181       if Right.Node.Key = null then
 182          raise Program_Error with "Right cursor in ""<"" is bad";
 183       end if;
 184
 185       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 186                      "Right cursor in ""<"" is bad");
 187
 188       return Left < Right.Node.Key.all;
 189    end "<";
 190
 191    ---------
 192    -- "=" --
 193    ---------
 194
 195    function "=" (Left, Right : Map) return Boolean is
 196    begin
 197       return Is_Equal (Left.Tree, Right.Tree);
 198    end "=";
 199
 200    ---------
 201    -- ">" --
 202    ---------
 203
 204    function ">" (Left, Right : Cursor) return Boolean is
 205    begin
 206       if Left.Node = null then
 207          raise Constraint_Error with "Left cursor of "">"" equals No_Element";
 208       end if;
 209
 210       if Right.Node = null then
 211          raise Constraint_Error with "Right cursor of "">"" equals No_Element";
 212       end if;
 213
 214       if Left.Node.Key = null then
 215          raise Program_Error with "Left cursor in ""<"" is bad";
 216       end if;
 217
 218       if Right.Node.Key = null then
 219          raise Program_Error with "Right cursor in ""<"" is bad";
 220       end if;
 221
 222       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 223                      "Left cursor in "">"" is bad");
 224
 225       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 226                      "Right cursor in "">"" is bad");
 227
 228       return Right.Node.Key.all < Left.Node.Key.all;
 229    end ">";
 230
 231    function ">" (Left : Cursor; Right : Key_Type) return Boolean is
 232    begin
 233       if Left.Node = null then
 234          raise Constraint_Error with "Left cursor of "">"" equals No_Element";
 235       end if;
 236
 237       if Left.Node.Key = null then
 238          raise Program_Error with "Left cursor in ""<"" is bad";
 239       end if;
 240
 241       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 242                      "Left cursor in "">"" is bad");
 243
 244       return Right < Left.Node.Key.all;
 245    end ">";
 246
 247    function ">" (Left : Key_Type; Right : Cursor) return Boolean is
 248    begin
 249       if Right.Node = null then
 250          raise Constraint_Error with "Right cursor of "">"" equals No_Element";
 251       end if;
 252
 253       if Right.Node.Key = null then
 254          raise Program_Error with "Right cursor in ""<"" is bad";
 255       end if;
 256
 257       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 258                      "Right cursor in "">"" is bad");
 259
 260       return Right.Node.Key.all < Left;
 261    end ">";
 262
 263    ------------
 264    -- Adjust --
 265    ------------
 266
 267    procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree);
 268
 269    procedure Adjust (Container : in out Map) is
 270    begin
 271       Adjust (Container.Tree);
 272    end Adjust;
 273
 274    procedure Adjust (Control : in out Reference_Control_Type) is
 275    begin
 276       if Control.Container /= null then
 277          declare
 278             T : Tree_Type renames Control.Container.all.Tree;
 279             B : Natural renames T.Busy;
 280             L : Natural renames T.Lock;
 281          begin
 282             B := B + 1;
 283             L := L + 1;
 284          end;
 285       end if;
 286    end Adjust;
 287
 288    ------------
 289    -- Assign --
 290    ------------
 291
 292    procedure Assign (Target : in out Map; Source : Map) is
 293       procedure Insert_Item (Node : Node_Access);
 294       pragma Inline (Insert_Item);
 295
 296       procedure Insert_Items is
 297          new Tree_Operations.Generic_Iteration (Insert_Item);
 298
 299       -----------------
 300       -- Insert_Item --
 301       -----------------
 302
 303       procedure Insert_Item (Node : Node_Access) is
 304       begin
 305          Target.Insert (Key => Node.Key.all, New_Item => Node.Element.all);
 306       end Insert_Item;
 307
 308    --  Start of processing for Assign
 309
 310    begin
 311       if Target'Address = Source'Address then
 312          return;
 313       end if;
 314
 315       Target.Clear;
 316       Insert_Items (Source.Tree);
 317    end Assign;
 318
 319    -------------
 320    -- Ceiling --
 321    -------------
 322
 323    function Ceiling (Container : Map; Key : Key_Type) return Cursor is
 324       Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
 325    begin
 326       return (if Node = null then No_Element
 327                 else Cursor'(Container'Unrestricted_Access, Node));
 328    end Ceiling;
 329
 330    -----------
 331    -- Clear --
 332    -----------
 333
 334    procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree);
 335
 336    procedure Clear (Container : in out Map) is
 337    begin
 338       Clear (Container.Tree);
 339    end Clear;
 340
 341    -----------
 342    -- Color --
 343    -----------
 344
 345    function Color (Node : Node_Access) return Color_Type is
 346    begin
 347       return Node.Color;
 348    end Color;
 349
 350    ------------------------
 351    -- Constant_Reference --
 352    ------------------------
 353
 354    function Constant_Reference
 355      (Container : aliased Map;
 356       Position  : Cursor) return Constant_Reference_Type
 357    is
 358    begin
 359       if Position.Container = null then
 360          raise Constraint_Error with
 361            "Position cursor has no element";
 362       end if;
 363
 364       if Position.Container /= Container'Unrestricted_Access then
 365          raise Program_Error with
 366            "Position cursor designates wrong map";
 367       end if;
 368
 369       if Position.Node.Element = null then
 370          raise Program_Error with "Node has no element";
 371       end if;
 372
 373       pragma Assert (Vet (Container.Tree, Position.Node),
 374                      "Position cursor in Constant_Reference is bad");
 375
 376       declare
 377          T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
 378          B : Natural renames T.Busy;
 379          L : Natural renames T.Lock;
 380       begin
 381          return R : constant Constant_Reference_Type :=
 382            (Element => Position.Node.Element.all'Access,
 383             Control => (Controlled with Container'Unrestricted_Access))
 384          do
 385             B := B + 1;
 386             L := L + 1;
 387          end return;
 388       end;
 389    end Constant_Reference;
 390
 391    function Constant_Reference
 392      (Container : aliased Map;
 393       Key       : Key_Type) return Constant_Reference_Type
 394    is
 395       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
 396
 397    begin
 398       if Node = null then
 399          raise Constraint_Error with "key not in map";
 400       end if;
 401
 402       if Node.Element = null then
 403          raise Program_Error with "Node has no element";
 404       end if;
 405
 406       declare
 407          T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
 408          B : Natural renames T.Busy;
 409          L : Natural renames T.Lock;
 410       begin
 411          return R : constant Constant_Reference_Type :=
 412            (Element => Node.Element.all'Access,
 413             Control => (Controlled with Container'Unrestricted_Access))
 414          do
 415             B := B + 1;
 416             L := L + 1;
 417          end return;
 418       end;
 419    end Constant_Reference;
 420
 421    --------------
 422    -- Contains --
 423    --------------
 424
 425    function Contains (Container : Map; Key : Key_Type) return Boolean is
 426    begin
 427       return Find (Container, Key) /= No_Element;
 428    end Contains;
 429
 430    ----------
 431    -- Copy --
 432    ----------
 433
 434    function Copy (Source : Map) return Map is
 435    begin
 436       return Target : Map do
 437          Target.Assign (Source);
 438       end return;
 439    end Copy;
 440
 441    ---------------
 442    -- Copy_Node --
 443    ---------------
 444
 445    function Copy_Node (Source : Node_Access) return Node_Access is
 446       K : Key_Access := new Key_Type'(Source.Key.all);
 447       E : Element_Access;
 448
 449    begin
 450       E := new Element_Type'(Source.Element.all);
 451
 452       return new Node_Type'(Parent  => null,
 453                             Left    => null,
 454                             Right   => null,
 455                             Color   => Source.Color,
 456                             Key     => K,
 457                             Element => E);
 458
 459    exception
 460       when others =>
 461          Free_Key (K);
 462          Free_Element (E);
 463          raise;
 464    end Copy_Node;
 465
 466    ------------
 467    -- Delete --
 468    ------------
 469
 470    procedure Delete
 471      (Container : in out Map;
 472       Position  : in out Cursor)
 473    is
 474    begin
 475       if Position.Node = null then
 476          raise Constraint_Error with
 477            "Position cursor of Delete equals No_Element";
 478       end if;
 479
 480       if Position.Node.Key = null
 481         or else Position.Node.Element = null
 482       then
 483          raise Program_Error with "Position cursor of Delete is bad";
 484       end if;
 485
 486       if Position.Container /= Container'Unrestricted_Access then
 487          raise Program_Error with
 488            "Position cursor of Delete designates wrong map";
 489       end if;
 490
 491       pragma Assert (Vet (Container.Tree, Position.Node),
 492                      "Position cursor of Delete is bad");
 493
 494       Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
 495       Free (Position.Node);
 496
 497       Position.Container := null;
 498    end Delete;
 499
 500    procedure Delete (Container : in out Map; Key : Key_Type) is
 501       X : Node_Access := Key_Ops.Find (Container.Tree, Key);
 502
 503    begin
 504       if X = null then
 505          raise Constraint_Error with "key not in map";
 506       end if;
 507
 508       Delete_Node_Sans_Free (Container.Tree, X);
 509       Free (X);
 510    end Delete;
 511
 512    ------------------
 513    -- Delete_First --
 514    ------------------
 515
 516    procedure Delete_First (Container : in out Map) is
 517       X : Node_Access := Container.Tree.First;
 518    begin
 519       if X /= null then
 520          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 521          Free (X);
 522       end if;
 523    end Delete_First;
 524
 525    -----------------
 526    -- Delete_Last --
 527    -----------------
 528
 529    procedure Delete_Last (Container : in out Map) is
 530       X : Node_Access := Container.Tree.Last;
 531    begin
 532       if X /= null then
 533          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 534          Free (X);
 535       end if;
 536    end Delete_Last;
 537
 538    -------------
 539    -- Element --
 540    -------------
 541
 542    function Element (Position : Cursor) return Element_Type is
 543    begin
 544       if Position.Node = null then
 545          raise Constraint_Error with
 546            "Position cursor of function Element equals No_Element";
 547       end if;
 548
 549       if Position.Node.Element = null then
 550          raise Program_Error with
 551            "Position cursor of function Element is bad";
 552       end if;
 553
 554       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 555                      "Position cursor of function Element is bad");
 556
 557       return Position.Node.Element.all;
 558    end Element;
 559
 560    function Element (Container : Map; Key : Key_Type) return Element_Type is
 561       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
 562
 563    begin
 564       if Node = null then
 565          raise Constraint_Error with "key not in map";
 566       end if;
 567
 568       return Node.Element.all;
 569    end Element;
 570
 571    ---------------------
 572    -- Equivalent_Keys --
 573    ---------------------
 574
 575    function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
 576    begin
 577       return (if Left < Right or else Right < Left then False else True);
 578    end Equivalent_Keys;
 579
 580    -------------
 581    -- Exclude --
 582    -------------
 583
 584    procedure Exclude (Container : in out Map; Key : Key_Type) is
 585       X : Node_Access := Key_Ops.Find (Container.Tree, Key);
 586    begin
 587       if X /= null then
 588          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 589          Free (X);
 590       end if;
 591    end Exclude;
 592
 593    --------------
 594    -- Finalize --
 595    --------------
 596
 597    procedure Finalize (Object : in out Iterator) is
 598    begin
 599       if Object.Container /= null then
 600          declare
 601             B : Natural renames Object.Container.all.Tree.Busy;
 602          begin
 603             B := B - 1;
 604          end;
 605       end if;
 606    end Finalize;
 607
 608    procedure Finalize (Control : in out Reference_Control_Type) is
 609    begin
 610       if Control.Container /= null then
 611          declare
 612             T : Tree_Type renames Control.Container.all.Tree;
 613             B : Natural renames T.Busy;
 614             L : Natural renames T.Lock;
 615          begin
 616             B := B - 1;
 617             L := L - 1;
 618          end;
 619
 620          Control.Container := null;
 621       end if;
 622    end Finalize;
 623
 624    ----------
 625    -- Find --
 626    ----------
 627
 628    function Find (Container : Map; Key : Key_Type) return Cursor is
 629       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
 630    begin
 631       return (if Node = null then No_Element
 632               else Cursor'(Container'Unrestricted_Access, Node));
 633    end Find;
 634
 635    -----------
 636    -- First --
 637    -----------
 638
 639    function First (Container : Map) return Cursor is
 640       T : Tree_Type renames Container.Tree;
 641    begin
 642       return (if T.First = null then No_Element
 643               else Cursor'(Container'Unrestricted_Access, T.First));
 644    end First;
 645
 646    function First (Object : Iterator) return Cursor is
 647    begin
 648       --  The value of the iterator object's Node component influences the
 649       --  behavior of the First (and Last) selector function.
 650
 651       --  When the Node component is null, this means the iterator object was
 652       --  constructed without a start expression, in which case the (forward)
 653       --  iteration starts from the (logical) beginning of the entire sequence
 654       --  of items (corresponding to Container.First for a forward iterator).
 655
 656       --  Otherwise, this is iteration over a partial sequence of items. When
 657       --  the Node component is non-null, the iterator object was constructed
 658       --  with a start expression, that specifies the position from which the
 659       --  (forward) partial iteration begins.
 660
 661       if Object.Node = null then
 662          return Object.Container.First;
 663       else
 664          return Cursor'(Object.Container, Object.Node);
 665       end if;
 666    end First;
 667
 668    -------------------
 669    -- First_Element --
 670    -------------------
 671
 672    function First_Element (Container : Map) return Element_Type is
 673       T : Tree_Type renames Container.Tree;
 674    begin
 675       if T.First = null then
 676          raise Constraint_Error with "map is empty";
 677       else
 678          return T.First.Element.all;
 679       end if;
 680    end First_Element;
 681
 682    ---------------
 683    -- First_Key --
 684    ---------------
 685
 686    function First_Key (Container : Map) return Key_Type is
 687       T : Tree_Type renames Container.Tree;
 688    begin
 689       if T.First = null then
 690          raise Constraint_Error with "map is empty";
 691       else
 692          return T.First.Key.all;
 693       end if;
 694    end First_Key;
 695
 696    -----------
 697    -- Floor --
 698    -----------
 699
 700    function Floor (Container : Map; Key : Key_Type) return Cursor is
 701       Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
 702    begin
 703       return (if Node = null then No_Element
 704               else Cursor'(Container'Unrestricted_Access, Node));
 705    end Floor;
 706
 707    ----------
 708    -- Free --
 709    ----------
 710
 711    procedure Free (X : in out Node_Access) is
 712       procedure Deallocate is
 713         new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 714
 715    begin
 716       if X = null then
 717          return;
 718       end if;
 719
 720       X.Parent := X;
 721       X.Left := X;
 722       X.Right := X;
 723
 724       begin
 725          Free_Key (X.Key);
 726
 727       exception
 728          when others =>
 729             X.Key := null;
 730
 731             begin
 732                Free_Element (X.Element);
 733             exception
 734                when others =>
 735                   X.Element := null;
 736             end;
 737
 738             Deallocate (X);
 739             raise;
 740       end;
 741
 742       begin
 743          Free_Element (X.Element);
 744
 745       exception
 746          when others =>
 747             X.Element := null;
 748
 749             Deallocate (X);
 750             raise;
 751       end;
 752
 753       Deallocate (X);
 754    end Free;
 755
 756    -----------------
 757    -- Has_Element --
 758    -----------------
 759
 760    function Has_Element (Position : Cursor) return Boolean is
 761    begin
 762       return Position /= No_Element;
 763    end Has_Element;
 764
 765    -------------
 766    -- Include --
 767    -------------
 768
 769    procedure Include
 770      (Container : in out Map;
 771       Key       : Key_Type;
 772       New_Item  : Element_Type)
 773    is
 774       Position : Cursor;
 775       Inserted : Boolean;
 776
 777       K : Key_Access;
 778       E : Element_Access;
 779
 780    begin
 781       Insert (Container, Key, New_Item, Position, Inserted);
 782
 783       if not Inserted then
 784          if Container.Tree.Lock > 0 then
 785             raise Program_Error with
 786               "attempt to tamper with elements (map is locked)";
 787          end if;
 788
 789          K := Position.Node.Key;
 790          E := Position.Node.Element;
 791
 792          Position.Node.Key := new Key_Type'(Key);
 793
 794          declare
 795             --  The element allocator may need an accessibility check in the
 796             --  case the actual type is class-wide or has access discriminants
 797             --  (see RM 4.8(10.1) and AI12-0035).
 798
 799             pragma Unsuppress (Accessibility_Check);
 800
 801          begin
 802             Position.Node.Element := new Element_Type'(New_Item);
 803
 804          exception
 805             when others =>
 806                Free_Key (K);
 807                raise;
 808          end;
 809
 810          Free_Key (K);
 811          Free_Element (E);
 812       end if;
 813    end Include;
 814
 815    ------------
 816    -- Insert --
 817    ------------
 818
 819    procedure Insert
 820      (Container : in out Map;
 821       Key       : Key_Type;
 822       New_Item  : Element_Type;
 823       Position  : out Cursor;
 824       Inserted  : out Boolean)
 825    is
 826       function New_Node return Node_Access;
 827       pragma Inline (New_Node);
 828
 829       procedure Insert_Post is
 830         new Key_Ops.Generic_Insert_Post (New_Node);
 831
 832       procedure Insert_Sans_Hint is
 833         new Key_Ops.Generic_Conditional_Insert (Insert_Post);
 834
 835       --------------
 836       -- New_Node --
 837       --------------
 838
 839       function New_Node return Node_Access is
 840          Node : Node_Access := new Node_Type;
 841
 842          --  The element allocator may need an accessibility check in the case
 843          --  the actual type is class-wide or has access discriminants (see
 844          --  RM 4.8(10.1) and AI12-0035).
 845
 846          pragma Unsuppress (Accessibility_Check);
 847
 848       begin
 849          Node.Key := new Key_Type'(Key);
 850          Node.Element := new Element_Type'(New_Item);
 851          return Node;
 852
 853       exception
 854          when others =>
 855
 856             --  On exception, deallocate key and elem. Note that free
 857             --  deallocates both the key and the elem.
 858
 859             Free (Node);
 860             raise;
 861       end New_Node;
 862
 863    --  Start of processing for Insert
 864
 865    begin
 866       Insert_Sans_Hint
 867         (Container.Tree,
 868          Key,
 869          Position.Node,
 870          Inserted);
 871
 872       Position.Container := Container'Unrestricted_Access;
 873    end Insert;
 874
 875    procedure Insert
 876      (Container : in out Map;
 877       Key       : Key_Type;
 878       New_Item  : Element_Type)
 879    is
 880       Position : Cursor;
 881       pragma Unreferenced (Position);
 882
 883       Inserted : Boolean;
 884
 885    begin
 886       Insert (Container, Key, New_Item, Position, Inserted);
 887
 888       if not Inserted then
 889          raise Constraint_Error with "key already in map";
 890       end if;
 891    end Insert;
 892
 893    --------------
 894    -- Is_Empty --
 895    --------------
 896
 897    function Is_Empty (Container : Map) return Boolean is
 898    begin
 899       return Container.Tree.Length = 0;
 900    end Is_Empty;
 901
 902    ------------------------
 903    -- Is_Equal_Node_Node --
 904    ------------------------
 905
 906    function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
 907    begin
 908       return (if L.Key.all < R.Key.all then False
 909               elsif R.Key.all < L.Key.all then False
 910               else L.Element.all = R.Element.all);
 911    end Is_Equal_Node_Node;
 912
 913    -------------------------
 914    -- Is_Greater_Key_Node --
 915    -------------------------
 916
 917    function Is_Greater_Key_Node
 918      (Left  : Key_Type;
 919       Right : Node_Access) return Boolean
 920    is
 921    begin
 922       --  k > node same as node < k
 923
 924       return Right.Key.all < Left;
 925    end Is_Greater_Key_Node;
 926
 927    ----------------------
 928    -- Is_Less_Key_Node --
 929    ----------------------
 930
 931    function Is_Less_Key_Node
 932      (Left  : Key_Type;
 933       Right : Node_Access) return Boolean is
 934    begin
 935       return Left < Right.Key.all;
 936    end Is_Less_Key_Node;
 937
 938    -------------
 939    -- Iterate --
 940    -------------
 941
 942    procedure Iterate
 943      (Container : Map;
 944       Process   : not null access procedure (Position : Cursor))
 945    is
 946       procedure Process_Node (Node : Node_Access);
 947       pragma Inline (Process_Node);
 948
 949       procedure Local_Iterate is
 950         new Tree_Operations.Generic_Iteration (Process_Node);
 951
 952       ------------------
 953       -- Process_Node --
 954       ------------------
 955
 956       procedure Process_Node (Node : Node_Access) is
 957       begin
 958          Process (Cursor'(Container'Unrestricted_Access, Node));
 959       end Process_Node;
 960
 961       B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
 962
 963    --  Start of processing for Iterate
 964
 965    begin
 966       B := B + 1;
 967
 968       begin
 969          Local_Iterate (Container.Tree);
 970
 971       exception
 972          when others =>
 973             B := B - 1;
 974             raise;
 975       end;
 976
 977       B := B - 1;
 978    end Iterate;
 979
 980    function Iterate
 981      (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
 982    is
 983       B  : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
 984
 985    begin
 986       --  The value of the Node component influences the behavior of the First
 987       --  and Last selector functions of the iterator object. When the Node
 988       --  component is null (as is the case here), this means the iterator
 989       --  object was constructed without a start expression. This is a complete
 990       --  iterator, meaning that the iteration starts from the (logical)
 991       --  beginning of the sequence of items.
 992
 993       --  Note: For a forward iterator, Container.First is the beginning, and
 994       --  for a reverse iterator, Container.Last is the beginning.
 995
 996       return It : constant Iterator :=
 997         (Limited_Controlled with
 998            Container => Container'Unrestricted_Access,
 999            Node      => null)
1000       do
1001          B := B + 1;
1002       end return;
1003    end Iterate;
1004
1005    function Iterate
1006      (Container : Map;
1007       Start     : Cursor)
1008       return Map_Iterator_Interfaces.Reversible_Iterator'Class
1009    is
1010       B  : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
1011
1012    begin
1013       --  It was formerly the case that when Start = No_Element, the partial
1014       --  iterator was defined to behave the same as for a complete iterator,
1015       --  and iterate over the entire sequence of items. However, those
1016       --  semantics were unintuitive and arguably error-prone (it is too easy
1017       --  to accidentally create an endless loop), and so they were changed,
1018       --  per the ARG meeting in Denver on 2011/11. However, there was no
1019       --  consensus about what positive meaning this corner case should have,
1020       --  and so it was decided to simply raise an exception. This does imply,
1021       --  however, that it is not possible to use a partial iterator to specify
1022       --  an empty sequence of items.
1023
1024       if Start = No_Element then
1025          raise Constraint_Error with
1026            "Start position for iterator equals No_Element";
1027       end if;
1028
1029       if Start.Container /= Container'Unrestricted_Access then
1030          raise Program_Error with
1031            "Start cursor of Iterate designates wrong map";
1032       end if;
1033
1034       pragma Assert (Vet (Container.Tree, Start.Node),
1035                      "Start cursor of Iterate is bad");
1036
1037       --  The value of the Node component influences the behavior of the First
1038       --  and Last selector functions of the iterator object. When the Node
1039       --  component is non-null (as is the case here), it means that this
1040       --  is a partial iteration, over a subset of the complete sequence of
1041       --  items. The iterator object was constructed with a start expression,
1042       --  indicating the position from which the iteration begins. Note that
1043       --  the start position has the same value irrespective of whether this
1044       --  is a forward or reverse iteration.
1045
1046       return It : constant Iterator :=
1047         (Limited_Controlled with
1048            Container => Container'Unrestricted_Access,
1049            Node      => Start.Node)
1050       do
1051          B := B + 1;
1052       end return;
1053    end Iterate;
1054
1055    ---------
1056    -- Key --
1057    ---------
1058
1059    function Key (Position : Cursor) return Key_Type is
1060    begin
1061       if Position.Node = null then
1062          raise Constraint_Error with
1063            "Position cursor of function Key equals No_Element";
1064       end if;
1065
1066       if Position.Node.Key = null then
1067          raise Program_Error with
1068            "Position cursor of function Key is bad";
1069       end if;
1070
1071       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1072                      "Position cursor of function Key is bad");
1073
1074       return Position.Node.Key.all;
1075    end Key;
1076
1077    ----------
1078    -- Last --
1079    ----------
1080
1081    function Last (Container : Map) return Cursor is
1082       T : Tree_Type renames Container.Tree;
1083    begin
1084       return (if T.Last = null then No_Element
1085               else Cursor'(Container'Unrestricted_Access, T.Last));
1086    end Last;
1087
1088    function Last (Object : Iterator) return Cursor is
1089    begin
1090       --  The value of the iterator object's Node component influences the
1091       --  behavior of the Last (and First) selector function.
1092
1093       --  When the Node component is null, this means the iterator object was
1094       --  constructed without a start expression, in which case the (reverse)
1095       --  iteration starts from the (logical) beginning of the entire sequence
1096       --  (corresponding to Container.Last, for a reverse iterator).
1097
1098       --  Otherwise, this is iteration over a partial sequence of items. When
1099       --  the Node component is non-null, the iterator object was constructed
1100       --  with a start expression, that specifies the position from which the
1101       --  (reverse) partial iteration begins.
1102
1103       if Object.Node = null then
1104          return Object.Container.Last;
1105       else
1106          return Cursor'(Object.Container, Object.Node);
1107       end if;
1108    end Last;
1109
1110    ------------------
1111    -- Last_Element --
1112    ------------------
1113
1114    function Last_Element (Container : Map) return Element_Type is
1115       T : Tree_Type renames Container.Tree;
1116
1117    begin
1118       if T.Last = null then
1119          raise Constraint_Error with "map is empty";
1120       end if;
1121
1122       return T.Last.Element.all;
1123    end Last_Element;
1124
1125    --------------
1126    -- Last_Key --
1127    --------------
1128
1129    function Last_Key (Container : Map) return Key_Type is
1130       T : Tree_Type renames Container.Tree;
1131
1132    begin
1133       if T.Last = null then
1134          raise Constraint_Error with "map is empty";
1135       end if;
1136
1137       return T.Last.Key.all;
1138    end Last_Key;
1139
1140    ----------
1141    -- Left --
1142    ----------
1143
1144    function Left (Node : Node_Access) return Node_Access is
1145    begin
1146       return Node.Left;
1147    end Left;
1148
1149    ------------
1150    -- Length --
1151    ------------
1152
1153    function Length (Container : Map) return Count_Type is
1154    begin
1155       return Container.Tree.Length;
1156    end Length;
1157
1158    ----------
1159    -- Move --
1160    ----------
1161
1162    procedure Move is new Tree_Operations.Generic_Move (Clear);
1163
1164    procedure Move (Target : in out Map; Source : in out Map) is
1165    begin
1166       Move (Target => Target.Tree, Source => Source.Tree);
1167    end Move;
1168
1169    ----------
1170    -- Next --
1171    ----------
1172
1173    function Next (Position : Cursor) return Cursor is
1174    begin
1175       if Position = No_Element then
1176          return No_Element;
1177       end if;
1178
1179       pragma Assert (Position.Node /= null);
1180       pragma Assert (Position.Node.Key /= null);
1181       pragma Assert (Position.Node.Element /= null);
1182       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1183                      "Position cursor of Next is bad");
1184
1185       declare
1186          Node : constant Node_Access :=
1187            Tree_Operations.Next (Position.Node);
1188       begin
1189          return (if Node = null then No_Element
1190                  else Cursor'(Position.Container, Node));
1191       end;
1192    end Next;
1193
1194    procedure Next (Position : in out Cursor) is
1195    begin
1196       Position := Next (Position);
1197    end Next;
1198
1199    function Next
1200      (Object   : Iterator;
1201       Position : Cursor) return Cursor
1202    is
1203    begin
1204       if Position.Container = null then
1205          return No_Element;
1206       end if;
1207
1208       if Position.Container /= Object.Container then
1209          raise Program_Error with
1210            "Position cursor of Next designates wrong map";
1211       end if;
1212
1213       return Next (Position);
1214    end Next;
1215
1216    ------------
1217    -- Parent --
1218    ------------
1219
1220    function Parent (Node : Node_Access) return Node_Access is
1221    begin
1222       return Node.Parent;
1223    end Parent;
1224
1225    --------------
1226    -- Previous --
1227    --------------
1228
1229    function Previous (Position : Cursor) return Cursor is
1230    begin
1231       if Position = No_Element then
1232          return No_Element;
1233       end if;
1234
1235       pragma Assert (Position.Node /= null);
1236       pragma Assert (Position.Node.Key /= null);
1237       pragma Assert (Position.Node.Element /= null);
1238       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1239                      "Position cursor of Previous is bad");
1240
1241       declare
1242          Node : constant Node_Access :=
1243            Tree_Operations.Previous (Position.Node);
1244       begin
1245          return (if Node = null then No_Element
1246                  else Cursor'(Position.Container, Node));
1247       end;
1248    end Previous;
1249
1250    procedure Previous (Position : in out Cursor) is
1251    begin
1252       Position := Previous (Position);
1253    end Previous;
1254
1255    function Previous
1256      (Object   : Iterator;
1257       Position : Cursor) return Cursor
1258    is
1259    begin
1260       if Position.Container = null then
1261          return No_Element;
1262       end if;
1263
1264       if Position.Container /= Object.Container then
1265          raise Program_Error with
1266            "Position cursor of Previous designates wrong map";
1267       end if;
1268
1269       return Previous (Position);
1270    end Previous;
1271
1272    -------------------
1273    -- Query_Element --
1274    -------------------
1275
1276    procedure Query_Element
1277      (Position : Cursor;
1278       Process  : not null access procedure (Key     : Key_Type;
1279                                             Element : Element_Type))
1280    is
1281    begin
1282       if Position.Node = null then
1283          raise Constraint_Error with
1284            "Position cursor of Query_Element equals No_Element";
1285       end if;
1286
1287       if Position.Node.Key = null
1288         or else Position.Node.Element = null
1289       then
1290          raise Program_Error with
1291            "Position cursor of Query_Element is bad";
1292       end if;
1293
1294       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1295                      "Position cursor of Query_Element is bad");
1296
1297       declare
1298          T : Tree_Type renames Position.Container.Tree;
1299
1300          B : Natural renames T.Busy;
1301          L : Natural renames T.Lock;
1302
1303       begin
1304          B := B + 1;
1305          L := L + 1;
1306
1307          declare
1308             K : Key_Type renames Position.Node.Key.all;
1309             E : Element_Type renames Position.Node.Element.all;
1310          begin
1311             Process (K, E);
1312          exception
1313             when others =>
1314                L := L - 1;
1315                B := B - 1;
1316                raise;
1317          end;
1318
1319          L := L - 1;
1320          B := B - 1;
1321       end;
1322    end Query_Element;
1323
1324    ----------
1325    -- Read --
1326    ----------
1327
1328    procedure Read
1329      (Stream    : not null access Root_Stream_Type'Class;
1330       Container : out Map)
1331    is
1332       function Read_Node
1333         (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1334       pragma Inline (Read_Node);
1335
1336       procedure Read is
1337          new Tree_Operations.Generic_Read (Clear, Read_Node);
1338
1339       ---------------
1340       -- Read_Node --
1341       ---------------
1342
1343       function Read_Node
1344         (Stream : not null access Root_Stream_Type'Class) return Node_Access
1345       is
1346          Node : Node_Access := new Node_Type;
1347       begin
1348          Node.Key := new Key_Type'(Key_Type'Input (Stream));
1349          Node.Element := new Element_Type'(Element_Type'Input (Stream));
1350          return Node;
1351       exception
1352          when others =>
1353             Free (Node);  --  Note that Free deallocates key and elem too
1354             raise;
1355       end Read_Node;
1356
1357    --  Start of processing for Read
1358
1359    begin
1360       Read (Stream, Container.Tree);
1361    end Read;
1362
1363    procedure Read
1364      (Stream : not null access Root_Stream_Type'Class;
1365       Item   : out Cursor)
1366    is
1367    begin
1368       raise Program_Error with "attempt to stream map cursor";
1369    end Read;
1370
1371    procedure Read
1372      (Stream : not null access Root_Stream_Type'Class;
1373       Item   : out Reference_Type)
1374    is
1375    begin
1376       raise Program_Error with "attempt to stream reference";
1377    end Read;
1378
1379    procedure Read
1380      (Stream : not null access Root_Stream_Type'Class;
1381       Item   : out Constant_Reference_Type)
1382    is
1383    begin
1384       raise Program_Error with "attempt to stream reference";
1385    end Read;
1386
1387    ---------------
1388    -- Reference --
1389    ---------------
1390
1391    function Reference
1392      (Container : aliased in out Map;
1393       Position  : Cursor) return Reference_Type
1394    is
1395    begin
1396       if Position.Container = null then
1397          raise Constraint_Error with
1398            "Position cursor has no element";
1399       end if;
1400
1401       if Position.Container /= Container'Unrestricted_Access then
1402          raise Program_Error with
1403            "Position cursor designates wrong map";
1404       end if;
1405
1406       if Position.Node.Element = null then
1407          raise Program_Error with "Node has no element";
1408       end if;
1409
1410       pragma Assert (Vet (Container.Tree, Position.Node),
1411                      "Position cursor in function Reference is bad");
1412
1413       declare
1414          T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
1415          B : Natural renames T.Busy;
1416          L : Natural renames T.Lock;
1417       begin
1418          return R : constant Reference_Type :=
1419            (Element => Position.Node.Element.all'Access,
1420             Control => (Controlled with Position.Container))
1421          do
1422             B := B + 1;
1423             L := L + 1;
1424          end return;
1425       end;
1426    end Reference;
1427
1428    function Reference
1429      (Container : aliased in out Map;
1430       Key       : Key_Type) return Reference_Type
1431    is
1432       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1433
1434    begin
1435       if Node = null then
1436          raise Constraint_Error with "key not in map";
1437       end if;
1438
1439       if Node.Element = null then
1440          raise Program_Error with "Node has no element";
1441       end if;
1442
1443       declare
1444          T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
1445          B : Natural renames T.Busy;
1446          L : Natural renames T.Lock;
1447       begin
1448          return R : constant Reference_Type :=
1449            (Element => Node.Element.all'Access,
1450             Control => (Controlled with Container'Unrestricted_Access))
1451          do
1452             B := B + 1;
1453             L := L + 1;
1454          end return;
1455       end;
1456    end Reference;
1457
1458    -------------
1459    -- Replace --
1460    -------------
1461
1462    procedure Replace
1463      (Container : in out Map;
1464       Key       : Key_Type;
1465       New_Item  : Element_Type)
1466    is
1467       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1468
1469       K : Key_Access;
1470       E : Element_Access;
1471
1472    begin
1473       if Node = null then
1474          raise Constraint_Error with "key not in map";
1475       end if;
1476
1477       if Container.Tree.Lock > 0 then
1478          raise Program_Error with
1479            "attempt to tamper with elements (map is locked)";
1480       end if;
1481
1482       K := Node.Key;
1483       E := Node.Element;
1484
1485       Node.Key := new Key_Type'(Key);
1486
1487       declare
1488          --  The element allocator may need an accessibility check in the case
1489          --  the actual type is class-wide or has access discriminants (see
1490          --  RM 4.8(10.1) and AI12-0035).
1491
1492          pragma Unsuppress (Accessibility_Check);
1493
1494       begin
1495          Node.Element := new Element_Type'(New_Item);
1496
1497       exception
1498          when others =>
1499             Free_Key (K);
1500             raise;
1501       end;
1502
1503       Free_Key (K);
1504       Free_Element (E);
1505    end Replace;
1506
1507    ---------------------
1508    -- Replace_Element --
1509    ---------------------
1510
1511    procedure Replace_Element
1512      (Container : in out Map;
1513       Position  : Cursor;
1514       New_Item  : Element_Type)
1515    is
1516    begin
1517       if Position.Node = null then
1518          raise Constraint_Error with
1519            "Position cursor of Replace_Element equals No_Element";
1520       end if;
1521
1522       if Position.Node.Key = null
1523         or else Position.Node.Element = null
1524       then
1525          raise Program_Error with
1526            "Position cursor of Replace_Element is bad";
1527       end if;
1528
1529       if Position.Container /= Container'Unrestricted_Access then
1530          raise Program_Error with
1531            "Position cursor of Replace_Element designates wrong map";
1532       end if;
1533
1534       if Container.Tree.Lock > 0 then
1535          raise Program_Error with
1536            "attempt to tamper with elements (map is locked)";
1537       end if;
1538
1539       pragma Assert (Vet (Container.Tree, Position.Node),
1540                      "Position cursor of Replace_Element is bad");
1541
1542       declare
1543          X : Element_Access := Position.Node.Element;
1544
1545          --  The element allocator may need an accessibility check in the case
1546          --  the actual type is class-wide or has access discriminants (see
1547          --  RM 4.8(10.1) and AI12-0035).
1548
1549          pragma Unsuppress (Accessibility_Check);
1550
1551       begin
1552          Position.Node.Element := new Element_Type'(New_Item);
1553          Free_Element (X);
1554       end;
1555    end Replace_Element;
1556
1557    ---------------------
1558    -- Reverse_Iterate --
1559    ---------------------
1560
1561    procedure Reverse_Iterate
1562      (Container : Map;
1563       Process   : not null access procedure (Position : Cursor))
1564    is
1565       procedure Process_Node (Node : Node_Access);
1566       pragma Inline (Process_Node);
1567
1568       procedure Local_Reverse_Iterate is
1569         new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1570
1571       ------------------
1572       -- Process_Node --
1573       ------------------
1574
1575       procedure Process_Node (Node : Node_Access) is
1576       begin
1577          Process (Cursor'(Container'Unrestricted_Access, Node));
1578       end Process_Node;
1579
1580       B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
1581
1582    --  Start of processing for Reverse_Iterate
1583
1584    begin
1585       B := B + 1;
1586
1587       begin
1588          Local_Reverse_Iterate (Container.Tree);
1589       exception
1590          when others =>
1591             B := B - 1;
1592             raise;
1593       end;
1594
1595       B := B - 1;
1596    end Reverse_Iterate;
1597
1598    -----------
1599    -- Right --
1600    -----------
1601
1602    function Right (Node : Node_Access) return Node_Access is
1603    begin
1604       return Node.Right;
1605    end Right;
1606
1607    ---------------
1608    -- Set_Color --
1609    ---------------
1610
1611    procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1612    begin
1613       Node.Color := Color;
1614    end Set_Color;
1615
1616    --------------
1617    -- Set_Left --
1618    --------------
1619
1620    procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1621    begin
1622       Node.Left := Left;
1623    end Set_Left;
1624
1625    ----------------
1626    -- Set_Parent --
1627    ----------------
1628
1629    procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1630    begin
1631       Node.Parent := Parent;
1632    end Set_Parent;
1633
1634    ---------------
1635    -- Set_Right --
1636    ---------------
1637
1638    procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1639    begin
1640       Node.Right := Right;
1641    end Set_Right;
1642
1643    --------------------
1644    -- Update_Element --
1645    --------------------
1646
1647    procedure Update_Element
1648      (Container : in out Map;
1649       Position  : Cursor;
1650       Process   : not null access procedure (Key     : Key_Type;
1651                                              Element : in out Element_Type))
1652    is
1653    begin
1654       if Position.Node = null then
1655          raise Constraint_Error with
1656            "Position cursor of Update_Element equals No_Element";
1657       end if;
1658
1659       if Position.Node.Key = null
1660         or else Position.Node.Element = null
1661       then
1662          raise Program_Error with
1663            "Position cursor of Update_Element is bad";
1664       end if;
1665
1666       if Position.Container /= Container'Unrestricted_Access then
1667          raise Program_Error with
1668            "Position cursor of Update_Element designates wrong map";
1669       end if;
1670
1671       pragma Assert (Vet (Container.Tree, Position.Node),
1672                      "Position cursor of Update_Element is bad");
1673
1674       declare
1675          T : Tree_Type renames Position.Container.Tree;
1676
1677          B : Natural renames T.Busy;
1678          L : Natural renames T.Lock;
1679
1680       begin
1681          B := B + 1;
1682          L := L + 1;
1683
1684          declare
1685             K : Key_Type renames Position.Node.Key.all;
1686             E : Element_Type renames Position.Node.Element.all;
1687          begin
1688             Process (K, E);
1689          exception
1690             when others =>
1691                L := L - 1;
1692                B := B - 1;
1693                raise;
1694          end;
1695
1696          L := L - 1;
1697          B := B - 1;
1698       end;
1699    end Update_Element;
1700
1701    -----------
1702    -- Write --
1703    -----------
1704
1705    procedure Write
1706      (Stream    : not null access Root_Stream_Type'Class;
1707       Container : Map)
1708    is
1709       procedure Write_Node
1710         (Stream : not null access Root_Stream_Type'Class;
1711          Node   : Node_Access);
1712       pragma Inline (Write_Node);
1713
1714       procedure Write is
1715          new Tree_Operations.Generic_Write (Write_Node);
1716
1717       ----------------
1718       -- Write_Node --
1719       ----------------
1720
1721       procedure Write_Node
1722         (Stream : not null access Root_Stream_Type'Class;
1723          Node   : Node_Access)
1724       is
1725       begin
1726          Key_Type'Output (Stream, Node.Key.all);
1727          Element_Type'Output (Stream, Node.Element.all);
1728       end Write_Node;
1729
1730    --  Start of processing for Write
1731
1732    begin
1733       Write (Stream, Container.Tree);
1734    end Write;
1735
1736    procedure Write
1737      (Stream : not null access Root_Stream_Type'Class;
1738       Item   : Cursor)
1739    is
1740    begin
1741       raise Program_Error with "attempt to stream map cursor";
1742    end Write;
1743
1744    procedure Write
1745      (Stream : not null access Root_Stream_Type'Class;
1746       Item   : Reference_Type)
1747    is
1748    begin
1749       raise Program_Error with "attempt to stream reference";
1750    end Write;
1751
1752    procedure Write
1753      (Stream : not null access Root_Stream_Type'Class;
1754       Item   : Constant_Reference_Type)
1755    is
1756    begin
1757       raise Program_Error with "attempt to stream reference";
1758    end Write;
1759
1760 end Ada.Containers.Indefinite_Ordered_Maps;