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