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