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