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