gcc/ada/a-coorma.adb

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