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