gcc/ada/a-coorma.adb

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