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-2007, 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       Position : Cursor;
 711       pragma Unreferenced (Position);
 712
 713       Inserted : Boolean;
 714
 715    begin
 716       Insert (Container, Key, New_Item, Position, Inserted);
 717
 718       if not Inserted then
 719          raise Constraint_Error with "key already in map";
 720       end if;
 721    end Insert;
 722
 723    --------------
 724    -- Is_Empty --
 725    --------------
 726
 727    function Is_Empty (Container : Map) return Boolean is
 728    begin
 729       return Container.Tree.Length = 0;
 730    end Is_Empty;
 731
 732    ------------------------
 733    -- Is_Equal_Node_Node --
 734    ------------------------
 735
 736    function Is_Equal_Node_Node
 737      (L, R : Node_Access) return Boolean is
 738    begin
 739       if L.Key.all < R.Key.all then
 740          return False;
 741
 742       elsif R.Key.all < L.Key.all then
 743          return False;
 744
 745       else
 746          return L.Element.all = R.Element.all;
 747       end if;
 748    end Is_Equal_Node_Node;
 749
 750    -------------------------
 751    -- Is_Greater_Key_Node --
 752    -------------------------
 753
 754    function Is_Greater_Key_Node
 755      (Left  : Key_Type;
 756       Right : Node_Access) return Boolean
 757    is
 758    begin
 759       --  k > node same as node < k
 760
 761       return Right.Key.all < Left;
 762    end Is_Greater_Key_Node;
 763
 764    ----------------------
 765    -- Is_Less_Key_Node --
 766    ----------------------
 767
 768    function Is_Less_Key_Node
 769      (Left  : Key_Type;
 770       Right : Node_Access) return Boolean is
 771    begin
 772       return Left < Right.Key.all;
 773    end Is_Less_Key_Node;
 774
 775    -------------
 776    -- Iterate --
 777    -------------
 778
 779    procedure Iterate
 780      (Container : Map;
 781       Process   : not null access procedure (Position : Cursor))
 782    is
 783       procedure Process_Node (Node : Node_Access);
 784       pragma Inline (Process_Node);
 785
 786       procedure Local_Iterate is
 787         new Tree_Operations.Generic_Iteration (Process_Node);
 788
 789       ------------------
 790       -- Process_Node --
 791       ------------------
 792
 793       procedure Process_Node (Node : Node_Access) is
 794       begin
 795          Process (Cursor'(Container'Unrestricted_Access, Node));
 796       end Process_Node;
 797
 798       B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
 799
 800    --  Start of processing for Iterate
 801
 802    begin
 803       B := B + 1;
 804
 805       begin
 806          Local_Iterate (Container.Tree);
 807       exception
 808          when others =>
 809             B := B - 1;
 810             raise;
 811       end;
 812
 813       B := B - 1;
 814    end Iterate;
 815
 816    ---------
 817    -- Key --
 818    ---------
 819
 820    function Key (Position : Cursor) return Key_Type is
 821    begin
 822       if Position.Node = null then
 823          raise Constraint_Error with
 824            "Position cursor of function Key equals No_Element";
 825       end if;
 826
 827       if Position.Node.Key = null then
 828          raise Program_Error with
 829            "Position cursor of function Key is bad";
 830       end if;
 831
 832       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 833                      "Position cursor of function Key is bad");
 834
 835       return Position.Node.Key.all;
 836    end Key;
 837
 838    ----------
 839    -- Last --
 840    ----------
 841
 842    function Last (Container : Map) return Cursor is
 843       T : Tree_Type renames Container.Tree;
 844
 845    begin
 846       if T.Last = null then
 847          return No_Element;
 848       end if;
 849
 850       return Cursor'(Container'Unrestricted_Access, T.Last);
 851    end Last;
 852
 853    ------------------
 854    -- Last_Element --
 855    ------------------
 856
 857    function Last_Element (Container : Map) return Element_Type is
 858       T : Tree_Type renames Container.Tree;
 859
 860    begin
 861       if T.Last = null then
 862          raise Constraint_Error with "map is empty";
 863       end if;
 864
 865       return T.Last.Element.all;
 866    end Last_Element;
 867
 868    --------------
 869    -- Last_Key --
 870    --------------
 871
 872    function Last_Key (Container : Map) return Key_Type is
 873       T : Tree_Type renames Container.Tree;
 874
 875    begin
 876       if T.Last = null then
 877          raise Constraint_Error with "map is empty";
 878       end if;
 879
 880       return T.Last.Key.all;
 881    end Last_Key;
 882
 883    ----------
 884    -- Left --
 885    ----------
 886
 887    function Left (Node : Node_Access) return Node_Access is
 888    begin
 889       return Node.Left;
 890    end Left;
 891
 892    ------------
 893    -- Length --
 894    ------------
 895
 896    function Length (Container : Map) return Count_Type is
 897    begin
 898       return Container.Tree.Length;
 899    end Length;
 900
 901    ----------
 902    -- Move --
 903    ----------
 904
 905    procedure Move is
 906       new Tree_Operations.Generic_Move (Clear);
 907
 908    procedure Move (Target : in out Map; Source : in out Map) is
 909    begin
 910       Move (Target => Target.Tree, Source => Source.Tree);
 911    end Move;
 912
 913    ----------
 914    -- Next --
 915    ----------
 916
 917    function Next (Position : Cursor) return Cursor is
 918    begin
 919       if Position = No_Element then
 920          return No_Element;
 921       end if;
 922
 923       pragma Assert (Position.Node /= null);
 924       pragma Assert (Position.Node.Key /= null);
 925       pragma Assert (Position.Node.Element /= null);
 926       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 927                      "Position cursor of Next is bad");
 928
 929       declare
 930          Node : constant Node_Access :=
 931                   Tree_Operations.Next (Position.Node);
 932
 933       begin
 934          if Node = null then
 935             return No_Element;
 936          else
 937             return Cursor'(Position.Container, Node);
 938          end if;
 939       end;
 940    end Next;
 941
 942    procedure Next (Position : in out Cursor) is
 943    begin
 944       Position := Next (Position);
 945    end Next;
 946
 947    ------------
 948    -- Parent --
 949    ------------
 950
 951    function Parent (Node : Node_Access) return Node_Access is
 952    begin
 953       return Node.Parent;
 954    end Parent;
 955
 956    --------------
 957    -- Previous --
 958    --------------
 959
 960    function Previous (Position : Cursor) return Cursor is
 961    begin
 962       if Position = No_Element then
 963          return No_Element;
 964       end if;
 965
 966       pragma Assert (Position.Node /= null);
 967       pragma Assert (Position.Node.Key /= null);
 968       pragma Assert (Position.Node.Element /= null);
 969       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 970                      "Position cursor of Previous is bad");
 971
 972       declare
 973          Node : constant Node_Access :=
 974                   Tree_Operations.Previous (Position.Node);
 975
 976       begin
 977          if Node = null then
 978             return No_Element;
 979          end if;
 980
 981          return Cursor'(Position.Container, Node);
 982       end;
 983    end Previous;
 984
 985    procedure Previous (Position : in out Cursor) is
 986    begin
 987       Position := Previous (Position);
 988    end Previous;
 989
 990    -------------------
 991    -- Query_Element --
 992    -------------------
 993
 994    procedure Query_Element
 995      (Position : Cursor;
 996       Process  : not null access procedure (Key     : Key_Type;
 997                                             Element : Element_Type))
 998    is
 999    begin
1000       if Position.Node = null then
1001          raise Constraint_Error with
1002            "Position cursor of Query_Element equals No_Element";
1003       end if;
1004
1005       if Position.Node.Key = null
1006         or else Position.Node.Element = null
1007       then
1008          raise Program_Error with
1009            "Position cursor of Query_Element is bad";
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.all;
1027             E : Element_Type renames Position.Node.Element.all;
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          Node.Key := new Key_Type'(Key_Type'Input (Stream));
1068          Node.Element := new Element_Type'(Element_Type'Input (Stream));
1069          return Node;
1070       exception
1071          when others =>
1072             Free (Node);  --  Note that Free deallocates key and elem too
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    -------------
1091    -- Replace --
1092    -------------
1093
1094    procedure Replace
1095      (Container : in out Map;
1096       Key       : Key_Type;
1097       New_Item  : Element_Type)
1098    is
1099       Node : constant Node_Access :=
1100                Key_Ops.Find (Container.Tree, Key);
1101
1102       K : Key_Access;
1103       E : Element_Access;
1104
1105    begin
1106       if Node = null then
1107          raise Constraint_Error with "key not in map";
1108       end if;
1109
1110       if Container.Tree.Lock > 0 then
1111          raise Program_Error with
1112            "attempt to tamper with cursors (map is locked)";
1113       end if;
1114
1115       K := Node.Key;
1116       E := Node.Element;
1117
1118       Node.Key := new Key_Type'(Key);
1119
1120       begin
1121          Node.Element := new Element_Type'(New_Item);
1122       exception
1123          when others =>
1124             Free_Key (K);
1125             raise;
1126       end;
1127
1128       Free_Key (K);
1129       Free_Element (E);
1130    end Replace;
1131
1132    ---------------------
1133    -- Replace_Element --
1134    ---------------------
1135
1136    procedure Replace_Element
1137      (Container : in out Map;
1138       Position  : Cursor;
1139       New_Item  : Element_Type)
1140    is
1141    begin
1142       if Position.Node = null then
1143          raise Constraint_Error with
1144            "Position cursor of Replace_Element equals No_Element";
1145       end if;
1146
1147       if Position.Node.Key = null
1148         or else Position.Node.Element = null
1149       then
1150          raise Program_Error with
1151            "Position cursor of Replace_Element is bad";
1152       end if;
1153
1154       if Position.Container /= Container'Unrestricted_Access then
1155          raise Program_Error with
1156            "Position cursor of Replace_Element designates wrong map";
1157       end if;
1158
1159       if Container.Tree.Lock > 0 then
1160          raise Program_Error with
1161            "attempt to tamper with cursors (map is locked)";
1162       end if;
1163
1164       pragma Assert (Vet (Container.Tree, Position.Node),
1165                      "Position cursor of Replace_Element is bad");
1166
1167       declare
1168          X : Element_Access := Position.Node.Element;
1169
1170       begin
1171          Position.Node.Element := new Element_Type'(New_Item);
1172          Free_Element (X);
1173       end;
1174    end Replace_Element;
1175
1176    ---------------------
1177    -- Reverse_Iterate --
1178    ---------------------
1179
1180    procedure Reverse_Iterate
1181      (Container : Map;
1182       Process   : not null access procedure (Position : Cursor))
1183    is
1184       procedure Process_Node (Node : Node_Access);
1185       pragma Inline (Process_Node);
1186
1187       procedure Local_Reverse_Iterate is
1188         new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1189
1190       ------------------
1191       -- Process_Node --
1192       ------------------
1193
1194       procedure Process_Node (Node : Node_Access) is
1195       begin
1196          Process (Cursor'(Container'Unrestricted_Access, Node));
1197       end Process_Node;
1198
1199       B : Natural renames Container.Tree'Unrestricted_Access.all.Busy;
1200
1201    --  Start of processing for Reverse_Iterate
1202
1203    begin
1204       B := B + 1;
1205
1206       begin
1207          Local_Reverse_Iterate (Container.Tree);
1208       exception
1209          when others =>
1210             B := B - 1;
1211             raise;
1212       end;
1213
1214       B := B - 1;
1215    end Reverse_Iterate;
1216
1217    -----------
1218    -- Right --
1219    -----------
1220
1221    function Right (Node : Node_Access) return Node_Access is
1222    begin
1223       return Node.Right;
1224    end Right;
1225
1226    ---------------
1227    -- Set_Color --
1228    ---------------
1229
1230    procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1231    begin
1232       Node.Color := Color;
1233    end Set_Color;
1234
1235    --------------
1236    -- Set_Left --
1237    --------------
1238
1239    procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1240    begin
1241       Node.Left := Left;
1242    end Set_Left;
1243
1244    ----------------
1245    -- Set_Parent --
1246    ----------------
1247
1248    procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1249    begin
1250       Node.Parent := Parent;
1251    end Set_Parent;
1252
1253    ---------------
1254    -- Set_Right --
1255    ---------------
1256
1257    procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1258    begin
1259       Node.Right := Right;
1260    end Set_Right;
1261
1262    --------------------
1263    -- Update_Element --
1264    --------------------
1265
1266    procedure Update_Element
1267      (Container : in out Map;
1268       Position  : Cursor;
1269       Process   : not null access procedure (Key     : Key_Type;
1270                                              Element : in out Element_Type))
1271    is
1272    begin
1273       if Position.Node = null then
1274          raise Constraint_Error with
1275            "Position cursor of Update_Element equals No_Element";
1276       end if;
1277
1278       if Position.Node.Key = null
1279         or else Position.Node.Element = null
1280       then
1281          raise Program_Error with
1282            "Position cursor of Update_Element is bad";
1283       end if;
1284
1285       if Position.Container /= Container'Unrestricted_Access then
1286          raise Program_Error with
1287            "Position cursor of Update_Element designates wrong map";
1288       end if;
1289
1290       pragma Assert (Vet (Container.Tree, Position.Node),
1291                      "Position cursor of Update_Element is bad");
1292
1293       declare
1294          T : Tree_Type renames Position.Container.Tree;
1295
1296          B : Natural renames T.Busy;
1297          L : Natural renames T.Lock;
1298
1299       begin
1300          B := B + 1;
1301          L := L + 1;
1302
1303          declare
1304             K : Key_Type renames Position.Node.Key.all;
1305             E : Element_Type renames Position.Node.Element.all;
1306
1307          begin
1308             Process (K, E);
1309
1310          exception
1311             when others =>
1312                L := L - 1;
1313                B := B - 1;
1314                raise;
1315          end;
1316
1317          L := L - 1;
1318          B := B - 1;
1319       end;
1320    end Update_Element;
1321
1322    -----------
1323    -- Write --
1324    -----------
1325
1326    procedure Write
1327      (Stream    : not null access Root_Stream_Type'Class;
1328       Container : Map)
1329    is
1330       procedure Write_Node
1331         (Stream : not null access Root_Stream_Type'Class;
1332          Node   : Node_Access);
1333       pragma Inline (Write_Node);
1334
1335       procedure Write is
1336          new Tree_Operations.Generic_Write (Write_Node);
1337
1338       ----------------
1339       -- Write_Node --
1340       ----------------
1341
1342       procedure Write_Node
1343         (Stream : not null access Root_Stream_Type'Class;
1344          Node   : Node_Access)
1345       is
1346       begin
1347          Key_Type'Output (Stream, Node.Key.all);
1348          Element_Type'Output (Stream, Node.Element.all);
1349       end Write_Node;
1350
1351    --  Start of processing for Write
1352
1353    begin
1354       Write (Stream, Container.Tree);
1355    end Write;
1356
1357    procedure Write
1358      (Stream : not null access Root_Stream_Type'Class;
1359       Item   : Cursor)
1360    is
1361    begin
1362       raise Program_Error with "attempt to stream map cursor";
1363    end Write;
1364
1365 end Ada.Containers.Indefinite_Ordered_Maps;