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 (Target.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    exception
 459       when others =>
 460          Free_Key (K);
 461          Free_Element (E);
 462          raise;
 463    end Copy_Node;
 464
 465    ------------
 466    -- Delete --
 467    ------------
 468
 469    procedure Delete
 470      (Container : in out Map;
 471       Position  : in out Cursor)
 472    is
 473    begin
 474       if Position.Node = null then
 475          raise Constraint_Error with
 476            "Position cursor of Delete equals No_Element";
 477       end if;
 478
 479       if Position.Node.Key = null
 480         or else Position.Node.Element = null
 481       then
 482          raise Program_Error with "Position cursor of Delete is bad";
 483       end if;
 484
 485       if Position.Container /= Container'Unrestricted_Access then
 486          raise Program_Error with
 487            "Position cursor of Delete designates wrong map";
 488       end if;
 489
 490       pragma Assert (Vet (Container.Tree, Position.Node),
 491                      "Position cursor of Delete is bad");
 492
 493       Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
 494       Free (Position.Node);
 495
 496       Position.Container := null;
 497    end Delete;
 498
 499    procedure Delete (Container : in out Map; Key : Key_Type) is
 500       X : Node_Access := Key_Ops.Find (Container.Tree, Key);
 501
 502    begin
 503       if X = null then
 504          raise Constraint_Error with "key not in map";
 505       end if;
 506
 507       Delete_Node_Sans_Free (Container.Tree, X);
 508       Free (X);
 509    end Delete;
 510
 511    ------------------
 512    -- Delete_First --
 513    ------------------
 514
 515    procedure Delete_First (Container : in out Map) is
 516       X : Node_Access := Container.Tree.First;
 517    begin
 518       if X /= null then
 519          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 520          Free (X);
 521       end if;
 522    end Delete_First;
 523
 524    -----------------
 525    -- Delete_Last --
 526    -----------------
 527
 528    procedure Delete_Last (Container : in out Map) is
 529       X : Node_Access := Container.Tree.Last;
 530    begin
 531       if X /= null then
 532          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 533          Free (X);
 534       end if;
 535    end Delete_Last;
 536
 537    -------------
 538    -- Element --
 539    -------------
 540
 541    function Element (Position : Cursor) return Element_Type is
 542    begin
 543       if Position.Node = null then
 544          raise Constraint_Error with
 545            "Position cursor of function Element equals No_Element";
 546       end if;
 547
 548       if Position.Node.Element = null then
 549          raise Program_Error with
 550            "Position cursor of function Element is bad";
 551       end if;
 552
 553       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 554                      "Position cursor of function Element is bad");
 555
 556       return Position.Node.Element.all;
 557    end Element;
 558
 559    function Element (Container : Map; Key : Key_Type) return Element_Type is
 560       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
 561
 562    begin
 563       if Node = null then
 564          raise Constraint_Error with "key not in map";
 565       end if;
 566
 567       return Node.Element.all;
 568    end Element;
 569
 570    ---------------------
 571    -- Equivalent_Keys --
 572    ---------------------
 573
 574    function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
 575    begin
 576       return (if Left < Right or else Right < Left then False else True);
 577    end Equivalent_Keys;
 578
 579    -------------
 580    -- Exclude --
 581    -------------
 582
 583    procedure Exclude (Container : in out Map; Key : Key_Type) is
 584       X : Node_Access := Key_Ops.Find (Container.Tree, Key);
 585    begin
 586       if X /= null then
 587          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 588          Free (X);
 589       end if;
 590    end Exclude;
 591
 592    --------------
 593    -- Finalize --
 594    --------------
 595
 596    procedure Finalize (Object : in out Iterator) is
 597    begin
 598       if Object.Container /= null then
 599          declare
 600             B : Natural renames Object.Container.all.Tree.Busy;
 601          begin
 602             B := B - 1;
 603          end;
 604       end if;
 605    end Finalize;
 606
 607    procedure Finalize (Control : in out Reference_Control_Type) is
 608    begin
 609       if Control.Container /= null then
 610          declare
 611             T : Tree_Type renames Control.Container.all.Tree;
 612             B : Natural renames T.Busy;
 613             L : Natural renames T.Lock;
 614          begin
 615             B := B - 1;
 616             L := L - 1;
 617          end;
 618
 619          Control.Container := null;
 620       end if;
 621    end Finalize;
 622
 623    ----------
 624    -- Find --
 625    ----------
 626
 627    function Find (Container : Map; Key : Key_Type) return Cursor is
 628       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
 629    begin
 630       return (if Node = null then No_Element
 631               else Cursor'(Container'Unrestricted_Access, Node));
 632    end Find;
 633
 634    -----------
 635    -- First --
 636    -----------
 637
 638    function First (Container : Map) return Cursor is
 639       T : Tree_Type renames Container.Tree;
 640    begin
 641       return (if T.First = null then No_Element
 642               else Cursor'(Container'Unrestricted_Access, T.First));
 643    end First;
 644
 645    function First (Object : Iterator) return Cursor is
 646    begin
 647       --  The value of the iterator object's Node component influences the
 648       --  behavior of the First (and Last) selector function.
 649
 650       --  When the Node component is null, this means the iterator object was
 651       --  constructed without a start expression, in which case the (forward)
 652       --  iteration starts from the (logical) beginning of the entire sequence
 653       --  of items (corresponding to Container.First for a forward iterator).
 654
 655       --  Otherwise, this is iteration over a partial sequence of items. When
 656       --  the Node component is non-null, the iterator object was constructed
 657       --  with a start expression, that specifies the position from which the
 658       --  (forward) partial iteration begins.
 659
 660       if Object.Node = null then
 661          return Object.Container.First;
 662       else
 663          return Cursor'(Object.Container, Object.Node);
 664       end if;
 665    end First;
 666
 667    -------------------
 668    -- First_Element --
 669    -------------------
 670
 671    function First_Element (Container : Map) return Element_Type is
 672       T : Tree_Type renames Container.Tree;
 673    begin
 674       if T.First = null then
 675          raise Constraint_Error with "map is empty";
 676       else
 677          return T.First.Element.all;
 678       end if;
 679    end First_Element;
 680
 681    ---------------
 682    -- First_Key --
 683    ---------------
 684
 685    function First_Key (Container : Map) return Key_Type is
 686       T : Tree_Type renames Container.Tree;
 687    begin
 688       if T.First = null then
 689          raise Constraint_Error with "map is empty";
 690       else
 691          return T.First.Key.all;
 692       end if;
 693    end First_Key;
 694
 695    -----------
 696    -- Floor --
 697    -----------
 698
 699    function Floor (Container : Map; Key : Key_Type) return Cursor is
 700       Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
 701    begin
 702       return (if Node = null then No_Element
 703               else Cursor'(Container'Unrestricted_Access, Node));
 704    end Floor;
 705
 706    ----------
 707    -- Free --
 708    ----------
 709
 710    procedure Free (X : in out Node_Access) is
 711       procedure Deallocate is
 712         new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 713
 714    begin
 715       if X = null then
 716          return;
 717       end if;
 718
 719       X.Parent := X;
 720       X.Left := X;
 721       X.Right := X;
 722
 723       begin
 724          Free_Key (X.Key);
 725
 726       exception
 727          when others =>
 728             X.Key := null;
 729
 730             begin
 731                Free_Element (X.Element);
 732             exception
 733                when others =>
 734                   X.Element := null;
 735             end;
 736
 737             Deallocate (X);
 738             raise;
 739       end;
 740
 741       begin
 742          Free_Element (X.Element);
 743
 744       exception
 745          when others =>
 746             X.Element := null;
 747
 748             Deallocate (X);
 749             raise;
 750       end;
 751
 752       Deallocate (X);
 753    end Free;
 754
 755    -----------------
 756    -- Has_Element --
 757    -----------------
 758
 759    function Has_Element (Position : Cursor) return Boolean is
 760    begin
 761       return Position /= No_Element;
 762    end Has_Element;
 763
 764    -------------
 765    -- Include --
 766    -------------
 767
 768    procedure Include
 769      (Container : in out Map;
 770       Key       : Key_Type;
 771       New_Item  : Element_Type)
 772    is
 773       Position : Cursor;
 774       Inserted : Boolean;
 775
 776       K : Key_Access;
 777       E : Element_Access;
 778
 779    begin
 780       Insert (Container, Key, New_Item, Position, Inserted);
 781
 782       if not Inserted then
 783          if Container.Tree.Lock > 0 then
 784             raise Program_Error with
 785               "attempt to tamper with elements (map is locked)";
 786          end if;
 787
 788          K := Position.Node.Key;
 789          E := Position.Node.Element;
 790
 791          Position.Node.Key := new Key_Type'(Key);
 792
 793          declare
 794             --  The element allocator may need an accessibility check in the
 795             --  case the actual type is class-wide or has access discriminants
 796             --  (see RM 4.8(10.1) and AI12-0035).
 797
 798             pragma Unsuppress (Accessibility_Check);
 799
 800          begin
 801             Position.Node.Element := new Element_Type'(New_Item);
 802
 803          exception
 804             when others =>
 805                Free_Key (K);
 806                raise;
 807          end;
 808
 809          Free_Key (K);
 810          Free_Element (E);
 811       end if;
 812    end Include;
 813
 814    ------------
 815    -- Insert --
 816    ------------
 817
 818    procedure Insert
 819      (Container : in out Map;
 820       Key       : Key_Type;
 821       New_Item  : Element_Type;
 822       Position  : out Cursor;
 823       Inserted  : out Boolean)
 824    is
 825       function New_Node return Node_Access;
 826       pragma Inline (New_Node);
 827
 828       procedure Insert_Post is
 829         new Key_Ops.Generic_Insert_Post (New_Node);
 830
 831       procedure Insert_Sans_Hint is
 832         new Key_Ops.Generic_Conditional_Insert (Insert_Post);
 833
 834       --------------
 835       -- New_Node --
 836       --------------
 837
 838       function New_Node return Node_Access is
 839          Node : Node_Access := new Node_Type;
 840
 841          --  The element allocator may need an accessibility check in the case
 842          --  the actual type is class-wide or has access discriminants (see
 843          --  RM 4.8(10.1) and AI12-0035).
 844
 845          pragma Unsuppress (Accessibility_Check);
 846
 847       begin
 848          Node.Key := new Key_Type'(Key);
 849          Node.Element := new Element_Type'(New_Item);
 850          return Node;
 851
 852       exception
 853          when others =>
 854
 855             --  On exception, deallocate key and elem. Note that free
 856             --  deallocates both the key and the elem.
 857
 858             Free (Node);
 859             raise;
 860       end New_Node;
 861
 862    --  Start of processing for Insert
 863
 864    begin
 865       Insert_Sans_Hint
 866         (Container.Tree,
 867          Key,
 868          Position.Node,
 869          Inserted);
 870
 871       Position.Container := Container'Unrestricted_Access;
 872    end Insert;
 873
 874    procedure Insert
 875      (Container : in out Map;
 876       Key       : Key_Type;
 877       New_Item  : Element_Type)
 878    is
 879       Position : Cursor;
 880       pragma Unreferenced (Position);
 881
 882       Inserted : Boolean;
 883
 884    begin
 885       Insert (Container, Key, New_Item, Position, Inserted);
 886
 887       if not Inserted then
 888          raise Constraint_Error with "key already in map";
 889       end if;
 890    end Insert;
 891
 892    --------------
 893    -- Is_Empty --
 894    --------------
 895
 896    function Is_Empty (Container : Map) return Boolean is
 897    begin
 898       return Container.Tree.Length = 0;
 899    end Is_Empty;
 900
 901    ------------------------
 902    -- Is_Equal_Node_Node --
 903    ------------------------
 904
 905    function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
 906    begin
 907       return (if L.Key.all < R.Key.all then False
 908               elsif R.Key.all < L.Key.all then False
 909               else L.Element.all = R.Element.all);
 910    end Is_Equal_Node_Node;
 911
 912    -------------------------
 913    -- Is_Greater_Key_Node --
 914    -------------------------
 915
 916    function Is_Greater_Key_Node
 917      (Left  : Key_Type;
 918       Right : Node_Access) return Boolean
 919    is
 920    begin
 921       --  k > node same as node < k
 922
 923       return Right.Key.all < Left;
 924    end Is_Greater_Key_Node;
 925
 926    ----------------------
 927    -- Is_Less_Key_Node --
 928    ----------------------
 929
 930    function Is_Less_Key_Node
 931      (Left  : Key_Type;
 932       Right : Node_Access) return Boolean is
 933    begin
 934       return Left < Right.Key.all;
 935    end Is_Less_Key_Node;
 936
 937    -------------
 938    -- Iterate --
 939    -------------
 940
 941    procedure Iterate
 942      (Container : Map;
 943       Process   : not null access procedure (Position : Cursor))
 944    is
 945       procedure Process_Node (Node : Node_Access);
 946       pragma Inline (Process_Node);
 947
 948       procedure Local_Iterate is
 949         new Tree_Operations.Generic_Iteration (Process_Node);
 950
 951       ------------------
 952       -- Process_Node --
 953       ------------------
 954
 955       procedure Process_Node (Node : Node_Access) is
 956       begin
 957          Process (Cursor'(Container'Unrestricted_Access, Node));
 958       end Process_Node;
 959
 960       B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
 961
 962    --  Start of processing for Iterate
 963
 964    begin
 965       B := B + 1;
 966
 967       begin
 968          Local_Iterate (Container.Tree);
 969       exception
 970          when others =>
 971             B := B - 1;
 972             raise;
 973       end;
 974
 975       B := B - 1;
 976    end Iterate;
 977
 978    function Iterate
 979      (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class
 980    is
 981       B  : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
 982
 983    begin
 984       --  The value of the Node component influences the behavior of the First
 985       --  and Last selector functions of the iterator object. When the Node
 986       --  component is null (as is the case here), this means the iterator
 987       --  object was constructed without a start expression. This is a complete
 988       --  iterator, meaning that the iteration starts from the (logical)
 989       --  beginning of the sequence of items.
 990
 991       --  Note: For a forward iterator, Container.First is the beginning, and
 992       --  for a reverse iterator, Container.Last is the beginning.
 993
 994       return It : constant Iterator :=
 995         (Limited_Controlled with
 996            Container => Container'Unrestricted_Access,
 997            Node      => null)
 998       do
 999          B := B + 1;
1000       end return;
1001    end Iterate;
1002
1003    function Iterate
1004      (Container : Map;
1005       Start     : Cursor)
1006       return Map_Iterator_Interfaces.Reversible_Iterator'Class
1007    is
1008       B  : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
1009
1010    begin
1011       --  It was formerly the case that when Start = No_Element, the partial
1012       --  iterator was defined to behave the same as for a complete iterator,
1013       --  and iterate over the entire sequence of items. However, those
1014       --  semantics were unintuitive and arguably error-prone (it is too easy
1015       --  to accidentally create an endless loop), and so they were changed,
1016       --  per the ARG meeting in Denver on 2011/11. However, there was no
1017       --  consensus about what positive meaning this corner case should have,
1018       --  and so it was decided to simply raise an exception. This does imply,
1019       --  however, that it is not possible to use a partial iterator to specify
1020       --  an empty sequence of items.
1021
1022       if Start = No_Element then
1023          raise Constraint_Error with
1024            "Start position for iterator equals No_Element";
1025       end if;
1026
1027       if Start.Container /= Container'Unrestricted_Access then
1028          raise Program_Error with
1029            "Start cursor of Iterate designates wrong map";
1030       end if;
1031
1032       pragma Assert (Vet (Container.Tree, Start.Node),
1033                      "Start cursor of Iterate is bad");
1034
1035       --  The value of the Node component influences the behavior of the First
1036       --  and Last selector functions of the iterator object. When the Node
1037       --  component is non-null (as is the case here), it means that this
1038       --  is a partial iteration, over a subset of the complete sequence of
1039       --  items. The iterator object was constructed with a start expression,
1040       --  indicating the position from which the iteration begins. Note that
1041       --  the start position has the same value irrespective of whether this
1042       --  is a forward or reverse iteration.
1043
1044       return It : constant Iterator :=
1045         (Limited_Controlled with
1046            Container => Container'Unrestricted_Access,
1047            Node      => Start.Node)
1048       do
1049          B := B + 1;
1050       end return;
1051    end Iterate;
1052
1053    ---------
1054    -- Key --
1055    ---------
1056
1057    function Key (Position : Cursor) return Key_Type is
1058    begin
1059       if Position.Node = null then
1060          raise Constraint_Error with
1061            "Position cursor of function Key equals No_Element";
1062       end if;
1063
1064       if Position.Node.Key = null then
1065          raise Program_Error with
1066            "Position cursor of function Key is bad";
1067       end if;
1068
1069       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1070                      "Position cursor of function Key is bad");
1071
1072       return Position.Node.Key.all;
1073    end Key;
1074
1075    ----------
1076    -- Last --
1077    ----------
1078
1079    function Last (Container : Map) return Cursor is
1080       T : Tree_Type renames Container.Tree;
1081    begin
1082       return (if T.Last = null then No_Element
1083               else Cursor'(Container'Unrestricted_Access, T.Last));
1084    end Last;
1085
1086    function Last (Object : Iterator) return Cursor is
1087    begin
1088       --  The value of the iterator object's Node component influences the
1089       --  behavior of the Last (and First) selector function.
1090
1091       --  When the Node component is null, this means the iterator object was
1092       --  constructed without a start expression, in which case the (reverse)
1093       --  iteration starts from the (logical) beginning of the entire sequence
1094       --  (corresponding to Container.Last, for a reverse iterator).
1095
1096       --  Otherwise, this is iteration over a partial sequence of items. When
1097       --  the Node component is non-null, the iterator object was constructed
1098       --  with a start expression, that specifies the position from which the
1099       --  (reverse) partial iteration begins.
1100
1101       if Object.Node = null then
1102          return Object.Container.Last;
1103       else
1104          return Cursor'(Object.Container, Object.Node);
1105       end if;
1106    end Last;
1107
1108    ------------------
1109    -- Last_Element --
1110    ------------------
1111
1112    function Last_Element (Container : Map) return Element_Type is
1113       T : Tree_Type renames Container.Tree;
1114
1115    begin
1116       if T.Last = null then
1117          raise Constraint_Error with "map is empty";
1118       end if;
1119
1120       return T.Last.Element.all;
1121    end Last_Element;
1122
1123    --------------
1124    -- Last_Key --
1125    --------------
1126
1127    function Last_Key (Container : Map) return Key_Type is
1128       T : Tree_Type renames Container.Tree;
1129
1130    begin
1131       if T.Last = null then
1132          raise Constraint_Error with "map is empty";
1133       end if;
1134
1135       return T.Last.Key.all;
1136    end Last_Key;
1137
1138    ----------
1139    -- Left --
1140    ----------
1141
1142    function Left (Node : Node_Access) return Node_Access is
1143    begin
1144       return Node.Left;
1145    end Left;
1146
1147    ------------
1148    -- Length --
1149    ------------
1150
1151    function Length (Container : Map) return Count_Type is
1152    begin
1153       return Container.Tree.Length;
1154    end Length;
1155
1156    ----------
1157    -- Move --
1158    ----------
1159
1160    procedure Move is new Tree_Operations.Generic_Move (Clear);
1161
1162    procedure Move (Target : in out Map; Source : in out Map) is
1163    begin
1164       Move (Target => Target.Tree, Source => Source.Tree);
1165    end Move;
1166
1167    ----------
1168    -- Next --
1169    ----------
1170
1171    function Next (Position : Cursor) return Cursor is
1172    begin
1173       if Position = No_Element then
1174          return No_Element;
1175       end if;
1176
1177       pragma Assert (Position.Node /= null);
1178       pragma Assert (Position.Node.Key /= null);
1179       pragma Assert (Position.Node.Element /= null);
1180       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1181                      "Position cursor of Next is bad");
1182
1183       declare
1184          Node : constant Node_Access :=
1185            Tree_Operations.Next (Position.Node);
1186       begin
1187          return (if Node = null then No_Element
1188                  else Cursor'(Position.Container, Node));
1189       end;
1190    end Next;
1191
1192    procedure Next (Position : in out Cursor) is
1193    begin
1194       Position := Next (Position);
1195    end Next;
1196
1197    function Next
1198      (Object   : Iterator;
1199       Position : Cursor) return Cursor
1200    is
1201    begin
1202       if Position.Container = null then
1203          return No_Element;
1204       end if;
1205
1206       if Position.Container /= Object.Container then
1207          raise Program_Error with
1208            "Position cursor of Next designates wrong map";
1209       end if;
1210
1211       return Next (Position);
1212    end Next;
1213
1214    ------------
1215    -- Parent --
1216    ------------
1217
1218    function Parent (Node : Node_Access) return Node_Access is
1219    begin
1220       return Node.Parent;
1221    end Parent;
1222
1223    --------------
1224    -- Previous --
1225    --------------
1226
1227    function Previous (Position : Cursor) return Cursor is
1228    begin
1229       if Position = No_Element then
1230          return No_Element;
1231       end if;
1232
1233       pragma Assert (Position.Node /= null);
1234       pragma Assert (Position.Node.Key /= null);
1235       pragma Assert (Position.Node.Element /= null);
1236       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1237                      "Position cursor of Previous is bad");
1238
1239       declare
1240          Node : constant Node_Access :=
1241            Tree_Operations.Previous (Position.Node);
1242       begin
1243          return (if Node = null then No_Element
1244                  else Cursor'(Position.Container, Node));
1245       end;
1246    end Previous;
1247
1248    procedure Previous (Position : in out Cursor) is
1249    begin
1250       Position := Previous (Position);
1251    end Previous;
1252
1253    function Previous
1254      (Object   : Iterator;
1255       Position : Cursor) return Cursor
1256    is
1257    begin
1258       if Position.Container = null then
1259          return No_Element;
1260       end if;
1261
1262       if Position.Container /= Object.Container then
1263          raise Program_Error with
1264            "Position cursor of Previous designates wrong map";
1265       end if;
1266
1267       return Previous (Position);
1268    end Previous;
1269
1270    -------------------
1271    -- Query_Element --
1272    -------------------
1273
1274    procedure Query_Element
1275      (Position : Cursor;
1276       Process  : not null access procedure (Key     : Key_Type;
1277                                             Element : Element_Type))
1278    is
1279    begin
1280       if Position.Node = null then
1281          raise Constraint_Error with
1282            "Position cursor of Query_Element equals No_Element";
1283       end if;
1284
1285       if Position.Node.Key = null
1286         or else Position.Node.Element = null
1287       then
1288          raise Program_Error with
1289            "Position cursor of Query_Element is bad";
1290       end if;
1291
1292       pragma Assert (Vet (Position.Container.Tree, Position.Node),
1293                      "Position cursor of Query_Element is bad");
1294
1295       declare
1296          T : Tree_Type renames Position.Container.Tree;
1297
1298          B : Natural renames T.Busy;
1299          L : Natural renames T.Lock;
1300
1301       begin
1302          B := B + 1;
1303          L := L + 1;
1304
1305          declare
1306             K : Key_Type renames Position.Node.Key.all;
1307             E : Element_Type renames Position.Node.Element.all;
1308
1309          begin
1310             Process (K, E);
1311          exception
1312             when others =>
1313                L := L - 1;
1314                B := B - 1;
1315                raise;
1316          end;
1317
1318          L := L - 1;
1319          B := B - 1;
1320       end;
1321    end Query_Element;
1322
1323    ----------
1324    -- Read --
1325    ----------
1326
1327    procedure Read
1328      (Stream    : not null access Root_Stream_Type'Class;
1329       Container : out Map)
1330    is
1331       function Read_Node
1332         (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1333       pragma Inline (Read_Node);
1334
1335       procedure Read is
1336          new Tree_Operations.Generic_Read (Clear, Read_Node);
1337
1338       ---------------
1339       -- Read_Node --
1340       ---------------
1341
1342       function Read_Node
1343         (Stream : not null access Root_Stream_Type'Class) return Node_Access
1344       is
1345          Node : Node_Access := new Node_Type;
1346       begin
1347          Node.Key := new Key_Type'(Key_Type'Input (Stream));
1348          Node.Element := new Element_Type'(Element_Type'Input (Stream));
1349          return Node;
1350       exception
1351          when others =>
1352             Free (Node);  --  Note that Free deallocates key and elem too
1353             raise;
1354       end Read_Node;
1355
1356    --  Start of processing for Read
1357
1358    begin
1359       Read (Stream, Container.Tree);
1360    end Read;
1361
1362    procedure Read
1363      (Stream : not null access Root_Stream_Type'Class;
1364       Item   : out Cursor)
1365    is
1366    begin
1367       raise Program_Error with "attempt to stream map cursor";
1368    end Read;
1369
1370    procedure Read
1371      (Stream : not null access Root_Stream_Type'Class;
1372       Item   : out Reference_Type)
1373    is
1374    begin
1375       raise Program_Error with "attempt to stream reference";
1376    end Read;
1377
1378    procedure Read
1379      (Stream : not null access Root_Stream_Type'Class;
1380       Item   : out Constant_Reference_Type)
1381    is
1382    begin
1383       raise Program_Error with "attempt to stream reference";
1384    end Read;
1385
1386    ---------------
1387    -- Reference --
1388    ---------------
1389
1390    function Reference
1391      (Container : aliased in out Map;
1392       Position  : Cursor) return Reference_Type
1393    is
1394    begin
1395       if Position.Container = null then
1396          raise Constraint_Error with
1397            "Position cursor has no element";
1398       end if;
1399
1400       if Position.Container /= Container'Unrestricted_Access then
1401          raise Program_Error with
1402            "Position cursor designates wrong map";
1403       end if;
1404
1405       if Position.Node.Element = null then
1406          raise Program_Error with "Node has no element";
1407       end if;
1408
1409       pragma Assert (Vet (Container.Tree, Position.Node),
1410                      "Position cursor in function Reference is bad");
1411
1412       declare
1413          T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
1414          B : Natural renames T.Busy;
1415          L : Natural renames T.Lock;
1416       begin
1417          return R : constant Reference_Type :=
1418            (Element => Position.Node.Element.all'Access,
1419             Control => (Controlled with Position.Container))
1420          do
1421             B := B + 1;
1422             L := L + 1;
1423          end return;
1424       end;
1425    end Reference;
1426
1427    function Reference
1428      (Container : aliased in out Map;
1429       Key       : Key_Type) return Reference_Type
1430    is
1431       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1432
1433    begin
1434       if Node = null then
1435          raise Constraint_Error with "key not in map";
1436       end if;
1437
1438       if Node.Element = null then
1439          raise Program_Error with "Node has no element";
1440       end if;
1441
1442       declare
1443          T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
1444          B : Natural renames T.Busy;
1445          L : Natural renames T.Lock;
1446       begin
1447          return R : constant Reference_Type :=
1448            (Element => Node.Element.all'Access,
1449             Control => (Controlled with Container'Unrestricted_Access))
1450          do
1451             B := B + 1;
1452             L := L + 1;
1453          end return;
1454       end;
1455    end Reference;
1456
1457    -------------
1458    -- Replace --
1459    -------------
1460
1461    procedure Replace
1462      (Container : in out Map;
1463       Key       : Key_Type;
1464       New_Item  : Element_Type)
1465    is
1466       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
1467
1468       K : Key_Access;
1469       E : Element_Access;
1470
1471    begin
1472       if Node = null then
1473          raise Constraint_Error with "key not in map";
1474       end if;
1475
1476       if Container.Tree.Lock > 0 then
1477          raise Program_Error with
1478            "attempt to tamper with elements (map is locked)";
1479       end if;
1480
1481       K := Node.Key;
1482       E := Node.Element;
1483
1484       Node.Key := new Key_Type'(Key);
1485
1486       declare
1487          --  The element allocator may need an accessibility check in the case
1488          --  the actual type is class-wide or has access discriminants (see
1489          --  RM 4.8(10.1) and AI12-0035).
1490
1491          pragma Unsuppress (Accessibility_Check);
1492
1493       begin
1494          Node.Element := new Element_Type'(New_Item);
1495
1496       exception
1497          when others =>
1498             Free_Key (K);
1499             raise;
1500       end;
1501
1502       Free_Key (K);
1503       Free_Element (E);
1504    end Replace;
1505
1506    ---------------------
1507    -- Replace_Element --
1508    ---------------------
1509
1510    procedure Replace_Element
1511      (Container : in out Map;
1512       Position  : Cursor;
1513       New_Item  : Element_Type)
1514    is
1515    begin
1516       if Position.Node = null then
1517          raise Constraint_Error with
1518            "Position cursor of Replace_Element equals No_Element";
1519       end if;
1520
1521       if Position.Node.Key = null
1522         or else Position.Node.Element = null
1523       then
1524          raise Program_Error with
1525            "Position cursor of Replace_Element is bad";
1526       end if;
1527
1528       if Position.Container /= Container'Unrestricted_Access then
1529          raise Program_Error with
1530            "Position cursor of Replace_Element designates wrong map";
1531       end if;
1532
1533       if Container.Tree.Lock > 0 then
1534          raise Program_Error with
1535            "attempt to tamper with elements (map is locked)";
1536       end if;
1537
1538       pragma Assert (Vet (Container.Tree, Position.Node),
1539                      "Position cursor of Replace_Element is bad");
1540
1541       declare
1542          X : Element_Access := Position.Node.Element;
1543
1544          --  The element allocator may need an accessibility check in the case
1545          --  the actual type is class-wide or has access discriminants (see
1546          --  RM 4.8(10.1) and AI12-0035).
1547
1548          pragma Unsuppress (Accessibility_Check);
1549
1550       begin
1551          Position.Node.Element := new Element_Type'(New_Item);
1552          Free_Element (X);
1553       end;
1554    end Replace_Element;
1555
1556    ---------------------
1557    -- Reverse_Iterate --
1558    ---------------------
1559
1560    procedure Reverse_Iterate
1561      (Container : Map;
1562       Process   : not null access procedure (Position : Cursor))
1563    is
1564       procedure Process_Node (Node : Node_Access);
1565       pragma Inline (Process_Node);
1566
1567       procedure Local_Reverse_Iterate is
1568         new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1569
1570       ------------------
1571       -- Process_Node --
1572       ------------------
1573
1574       procedure Process_Node (Node : Node_Access) is
1575       begin
1576          Process (Cursor'(Container'Unrestricted_Access, Node));
1577       end Process_Node;
1578
1579       B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
1580
1581    --  Start of processing for Reverse_Iterate
1582
1583    begin
1584       B := B + 1;
1585
1586       begin
1587          Local_Reverse_Iterate (Container.Tree);
1588       exception
1589          when others =>
1590             B := B - 1;
1591             raise;
1592       end;
1593
1594       B := B - 1;
1595    end Reverse_Iterate;
1596
1597    -----------
1598    -- Right --
1599    -----------
1600
1601    function Right (Node : Node_Access) return Node_Access is
1602    begin
1603       return Node.Right;
1604    end Right;
1605
1606    ---------------
1607    -- Set_Color --
1608    ---------------
1609
1610    procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1611    begin
1612       Node.Color := Color;
1613    end Set_Color;
1614
1615    --------------
1616    -- Set_Left --
1617    --------------
1618
1619    procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1620    begin
1621       Node.Left := Left;
1622    end Set_Left;
1623
1624    ----------------
1625    -- Set_Parent --
1626    ----------------
1627
1628    procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1629    begin
1630       Node.Parent := Parent;
1631    end Set_Parent;
1632
1633    ---------------
1634    -- Set_Right --
1635    ---------------
1636
1637    procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1638    begin
1639       Node.Right := Right;
1640    end Set_Right;
1641
1642    --------------------
1643    -- Update_Element --
1644    --------------------
1645
1646    procedure Update_Element
1647      (Container : in out Map;
1648       Position  : Cursor;
1649       Process   : not null access procedure (Key     : Key_Type;
1650                                              Element : in out Element_Type))
1651    is
1652    begin
1653       if Position.Node = null then
1654          raise Constraint_Error with
1655            "Position cursor of Update_Element equals No_Element";
1656       end if;
1657
1658       if Position.Node.Key = null
1659         or else Position.Node.Element = null
1660       then
1661          raise Program_Error with
1662            "Position cursor of Update_Element is bad";
1663       end if;
1664
1665       if Position.Container /= Container'Unrestricted_Access then
1666          raise Program_Error with
1667            "Position cursor of Update_Element designates wrong map";
1668       end if;
1669
1670       pragma Assert (Vet (Container.Tree, Position.Node),
1671                      "Position cursor of Update_Element is bad");
1672
1673       declare
1674          T : Tree_Type renames Position.Container.Tree;
1675
1676          B : Natural renames T.Busy;
1677          L : Natural renames T.Lock;
1678
1679       begin
1680          B := B + 1;
1681          L := L + 1;
1682
1683          declare
1684             K : Key_Type renames Position.Node.Key.all;
1685             E : Element_Type renames Position.Node.Element.all;
1686
1687          begin
1688             Process (K, E);
1689
1690          exception
1691             when others =>
1692                L := L - 1;
1693                B := B - 1;
1694                raise;
1695          end;
1696
1697          L := L - 1;
1698          B := B - 1;
1699       end;
1700    end Update_Element;
1701
1702    -----------
1703    -- Write --
1704    -----------
1705
1706    procedure Write
1707      (Stream    : not null access Root_Stream_Type'Class;
1708       Container : Map)
1709    is
1710       procedure Write_Node
1711         (Stream : not null access Root_Stream_Type'Class;
1712          Node   : Node_Access);
1713       pragma Inline (Write_Node);
1714
1715       procedure Write is
1716          new Tree_Operations.Generic_Write (Write_Node);
1717
1718       ----------------
1719       -- Write_Node --
1720       ----------------
1721
1722       procedure Write_Node
1723         (Stream : not null access Root_Stream_Type'Class;
1724          Node   : Node_Access)
1725       is
1726       begin
1727          Key_Type'Output (Stream, Node.Key.all);
1728          Element_Type'Output (Stream, Node.Element.all);
1729       end Write_Node;
1730
1731    --  Start of processing for Write
1732
1733    begin
1734       Write (Stream, Container.Tree);
1735    end Write;
1736
1737    procedure Write
1738      (Stream : not null access Root_Stream_Type'Class;
1739       Item   : Cursor)
1740    is
1741    begin
1742       raise Program_Error with "attempt to stream map cursor";
1743    end Write;
1744
1745    procedure Write
1746      (Stream : not null access Root_Stream_Type'Class;
1747       Item   : Reference_Type)
1748    is
1749    begin
1750       raise Program_Error with "attempt to stream reference";
1751    end Write;
1752
1753    procedure Write
1754      (Stream : not null access Root_Stream_Type'Class;
1755       Item   : Constant_Reference_Type)
1756    is
1757    begin
1758       raise Program_Error with "attempt to stream reference";
1759    end Write;
1760
1761 end Ada.Containers.Indefinite_Ordered_Maps;