gcc/ada/a-cborma.adb

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