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