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