gcc/ada/a-ciorma.adb

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