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