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