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