gcc/ada/a-ciorma.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                 ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2007, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- This unit was originally developed by Matthew J Heaney.                  --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Unchecked_Deallocation;
  33
  34 with Ada.Containers.Red_Black_Trees.Generic_Operations;
  35 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
  36
  37 with Ada.Containers.Red_Black_Trees.Generic_Keys;
  38 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
  39
  40 package body Ada.Containers.Indefinite_Ordered_Maps is
  41
  42    -----------------------------
  43    -- Node Access Subprograms --
  44    -----------------------------
  45
  46    --  These subprograms provide a functional interface to access fields
  47    --  of a node, and a procedural interface for modifying these values.
  48
  49    function Color (Node : Node_Access) return Color_Type;
  50    pragma Inline (Color);
  51
  52    function Left (Node : Node_Access) return Node_Access;
  53    pragma Inline (Left);
  54
  55    function Parent (Node : Node_Access) return Node_Access;
  56    pragma Inline (Parent);
  57
  58    function Right (Node : Node_Access) return Node_Access;
  59    pragma Inline (Right);
  60
  61    procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
  62    pragma Inline (Set_Parent);
  63
  64    procedure Set_Left (Node : Node_Access; Left : Node_Access);
  65    pragma Inline (Set_Left);
  66
  67    procedure Set_Right (Node : Node_Access; Right : Node_Access);
  68    pragma Inline (Set_Right);
  69
  70    procedure Set_Color (Node : Node_Access; Color : Color_Type);
  71    pragma Inline (Set_Color);
  72
  73    -----------------------
  74    -- Local Subprograms --
  75    -----------------------
  76
  77    function Copy_Node (Source : Node_Access) return Node_Access;
  78    pragma Inline (Copy_Node);
  79
  80    procedure Free (X : in out Node_Access);
  81
  82    function Is_Equal_Node_Node
  83      (L, R : Node_Access) return Boolean;
  84    pragma Inline (Is_Equal_Node_Node);
  85
  86    function Is_Greater_Key_Node
  87      (Left  : Key_Type;
  88       Right : Node_Access) return Boolean;
  89    pragma Inline (Is_Greater_Key_Node);
  90
  91    function Is_Less_Key_Node
  92      (Left  : Key_Type;
  93       Right : Node_Access) return Boolean;
  94    pragma Inline (Is_Less_Key_Node);
  95
  96    --------------------------
  97    -- Local Instantiations --
  98    --------------------------
  99
 100    package Tree_Operations is
 101      new Red_Black_Trees.Generic_Operations (Tree_Types);
 102
 103    procedure Delete_Tree is
 104       new Tree_Operations.Generic_Delete_Tree (Free);
 105
 106    function Copy_Tree is
 107       new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
 108
 109    use Tree_Operations;
 110
 111    package Key_Ops is
 112      new Red_Black_Trees.Generic_Keys
 113        (Tree_Operations     => Tree_Operations,
 114         Key_Type            => Key_Type,
 115         Is_Less_Key_Node    => Is_Less_Key_Node,
 116         Is_Greater_Key_Node => Is_Greater_Key_Node);
 117
 118    procedure Free_Key is
 119      new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
 120
 121    procedure Free_Element is
 122      new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
 123
 124    function Is_Equal is
 125      new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
 126
 127    ---------
 128    -- "<" --
 129    ---------
 130
 131    function "<" (Left, Right : Cursor) return Boolean is
 132    begin
 133       if Left.Node = null then
 134          raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
 135       end if;
 136
 137       if Right.Node = null then
 138          raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
 139       end if;
 140
 141       if Left.Node.Key = null then
 142          raise Program_Error with "Left cursor in ""<"" is bad";
 143       end if;
 144
 145       if Right.Node.Key = null then
 146          raise Program_Error with "Right cursor in ""<"" is bad";
 147       end if;
 148
 149       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 150                      "Left cursor in ""<"" is bad");
 151
 152       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 153                      "Right cursor in ""<"" is bad");
 154
 155       return Left.Node.Key.all < Right.Node.Key.all;
 156    end "<";
 157
 158    function "<" (Left : Cursor; Right : Key_Type) return Boolean is
 159    begin
 160       if Left.Node = null then
 161          raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
 162       end if;
 163
 164       if Left.Node.Key = null then
 165          raise Program_Error with "Left cursor in ""<"" is bad";
 166       end if;
 167
 168       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 169                      "Left cursor in ""<"" is bad");
 170
 171       return Left.Node.Key.all < Right;
 172    end "<";
 173
 174    function "<" (Left : Key_Type; Right : Cursor) return Boolean is
 175    begin
 176       if Right.Node = null then
 177          raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
 178       end if;
 179
 180       if Right.Node.Key = null then
 181          raise Program_Error with "Right cursor in ""<"" is bad";
 182       end if;
 183
 184       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 185                      "Right cursor in ""<"" is bad");
 186
 187       return Left < Right.Node.Key.all;
 188    end "<";
 189
 190    ---------
 191    -- "=" --
 192    ---------
 193
 194    function "=" (Left, Right : Map) return Boolean is
 195    begin
 196       return Is_Equal (Left.Tree, Right.Tree);
 197    end "=";
 198
 199    ---------
 200    -- ">" --
 201    ---------
 202
 203    function ">" (Left, Right : Cursor) return Boolean is
 204    begin
 205       if Left.Node = null then
 206          raise Constraint_Error with "Left cursor of "">"" equals No_Element";
 207       end if;
 208
 209       if Right.Node = null then
 210          raise Constraint_Error with "Right cursor of "">"" equals No_Element";
 211       end if;
 212
 213       if Left.Node.Key = null then
 214          raise Program_Error with "Left cursor in ""<"" is bad";
 215       end if;
 216
 217       if Right.Node.Key = null then
 218          raise Program_Error with "Right cursor in ""<"" is bad";
 219       end if;
 220
 221       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 222                      "Left cursor in "">"" is bad");
 223
 224       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 225                      "Right cursor in "">"" is bad");
 226
 227       return Right.Node.Key.all < Left.Node.Key.all;
 228    end ">";
 229
 230    function ">" (Left : Cursor; Right : Key_Type) return Boolean is
 231    begin
 232       if Left.Node = null then
 233          raise Constraint_Error with "Left cursor of "">"" equals No_Element";
 234       end if;
 235
 236       if Left.Node.Key = null then
 237          raise Program_Error with "Left cursor in ""<"" is bad";
 238       end if;
 239
 240       pragma Assert (Vet (Left.Container.Tree, Left.Node),
 241                      "Left cursor in "">"" is bad");
 242
 243       return Right < Left.Node.Key.all;
 244    end ">";
 245
 246    function ">" (Left : Key_Type; Right : Cursor) return Boolean is
 247    begin
 248       if Right.Node = null then
 249          raise Constraint_Error with "Right cursor of "">"" equals No_Element";
 250       end if;
 251
 252       if Right.Node.Key = null then
 253          raise Program_Error with "Right cursor in ""<"" is bad";
 254       end if;
 255
 256       pragma Assert (Vet (Right.Container.Tree, Right.Node),
 257                      "Right cursor in "">"" is bad");
 258
 259       return Right.Node.Key.all < Left;
 260    end ">";
 261
 262    ------------
 263    -- Adjust --
 264    ------------
 265
 266    procedure Adjust is
 267       new Tree_Operations.Generic_Adjust (Copy_Tree);
 268
 269    procedure Adjust (Container : in out Map) is
 270    begin
 271       Adjust (Container.Tree);
 272    end Adjust;
 273
 274    -------------
 275    -- Ceiling --
 276    -------------
 277
 278    function Ceiling (Container : Map; Key : Key_Type) return Cursor is
 279       Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key);
 280
 281    begin
 282       if Node = null then
 283          return No_Element;
 284       end if;
 285
 286       return Cursor'(Container'Unrestricted_Access, Node);
 287    end Ceiling;
 288
 289    -----------
 290    -- Clear --
 291    -----------
 292
 293    procedure Clear is
 294       new Tree_Operations.Generic_Clear (Delete_Tree);
 295
 296    procedure Clear (Container : in out Map) is
 297    begin
 298       Clear (Container.Tree);
 299    end Clear;
 300
 301    -----------
 302    -- Color --
 303    -----------
 304
 305    function Color (Node : Node_Access) return Color_Type is
 306    begin
 307       return Node.Color;
 308    end Color;
 309
 310    --------------
 311    -- Contains --
 312    --------------
 313
 314    function Contains (Container : Map; Key : Key_Type) return Boolean is
 315    begin
 316       return Find (Container, Key) /= No_Element;
 317    end Contains;
 318
 319    ---------------
 320    -- Copy_Node --
 321    ---------------
 322
 323    function Copy_Node (Source : Node_Access) return Node_Access is
 324       K : Key_Access := new Key_Type'(Source.Key.all);
 325       E : Element_Access;
 326    begin
 327       E := new Element_Type'(Source.Element.all);
 328
 329       return new Node_Type'(Parent  => null,
 330                             Left    => null,
 331                             Right   => null,
 332                             Color   => Source.Color,
 333                             Key     => K,
 334                             Element => E);
 335    exception
 336       when others =>
 337          Free_Key (K);
 338          Free_Element (E);
 339          raise;
 340    end Copy_Node;
 341
 342    ------------
 343    -- Delete --
 344    ------------
 345
 346    procedure Delete
 347      (Container : in out Map;
 348       Position  : in out Cursor)
 349    is
 350    begin
 351       if Position.Node = null then
 352          raise Constraint_Error with
 353            "Position cursor of Delete equals No_Element";
 354       end if;
 355
 356       if Position.Node.Key = null
 357         or else Position.Node.Element = null
 358       then
 359          raise Program_Error with "Position cursor of Delete is bad";
 360       end if;
 361
 362       if Position.Container /= Container'Unrestricted_Access then
 363          raise Program_Error with
 364            "Position cursor of Delete designates wrong map";
 365       end if;
 366
 367       pragma Assert (Vet (Container.Tree, Position.Node),
 368                      "Position cursor of Delete is bad");
 369
 370       Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
 371       Free (Position.Node);
 372
 373       Position.Container := null;
 374    end Delete;
 375
 376    procedure Delete (Container : in out Map; Key : Key_Type) is
 377       X : Node_Access := Key_Ops.Find (Container.Tree, Key);
 378
 379    begin
 380       if X = null then
 381          raise Constraint_Error with "key not in map";
 382       end if;
 383
 384       Delete_Node_Sans_Free (Container.Tree, X);
 385       Free (X);
 386    end Delete;
 387
 388    ------------------
 389    -- Delete_First --
 390    ------------------
 391
 392    procedure Delete_First (Container : in out Map) is
 393       X : Node_Access := Container.Tree.First;
 394
 395    begin
 396       if X /= null then
 397          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 398          Free (X);
 399       end if;
 400    end Delete_First;
 401
 402    -----------------
 403    -- Delete_Last --
 404    -----------------
 405
 406    procedure Delete_Last (Container : in out Map) is
 407       X : Node_Access := Container.Tree.Last;
 408
 409    begin
 410       if X /= null then
 411          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 412          Free (X);
 413       end if;
 414    end Delete_Last;
 415
 416    -------------
 417    -- Element --
 418    -------------
 419
 420    function Element (Position : Cursor) return Element_Type is
 421    begin
 422       if Position.Node = null then
 423          raise Constraint_Error with
 424            "Position cursor of function Element equals No_Element";
 425       end if;
 426
 427       if Position.Node.Element = null then
 428          raise Program_Error with
 429            "Position cursor of function Element is bad";
 430       end if;
 431
 432       pragma Assert (Vet (Position.Container.Tree, Position.Node),
 433                      "Position cursor of function Element is bad");
 434
 435       return Position.Node.Element.all;
 436    end Element;
 437
 438    function Element (Container : Map; Key : Key_Type) return Element_Type is
 439       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
 440
 441    begin
 442       if Node = null then
 443          raise Constraint_Error with "key not in map";
 444       end if;
 445
 446       return Node.Element.all;
 447    end Element;
 448
 449    ---------------------
 450    -- Equivalent_Keys --
 451    ---------------------
 452
 453    function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
 454    begin
 455       if Left < Right
 456         or else Right < Left
 457       then
 458          return False;
 459       else
 460          return True;
 461       end if;
 462    end Equivalent_Keys;
 463
 464    -------------
 465    -- Exclude --
 466    -------------
 467
 468    procedure Exclude (Container : in out Map; Key : Key_Type) is
 469       X : Node_Access := Key_Ops.Find (Container.Tree, Key);
 470
 471    begin
 472       if X /= null then
 473          Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
 474          Free (X);
 475       end if;
 476    end Exclude;
 477
 478    ----------
 479    -- Find --
 480    ----------
 481
 482    function Find (Container : Map; Key : Key_Type) return Cursor is
 483       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);
 484
 485    begin
 486       if Node = null then
 487          return No_Element;
 488       end if;
 489
 490       return Cursor'(Container'Unrestricted_Access, Node);
 491    end Find;
 492
 493    -----------
 494    -- First --
 495    -----------
 496
 497    function First (Container : Map) return Cursor is
 498       T : Tree_Type renames Container.Tree;
 499
 500    begin
 501       if T.First = null then
 502          return No_Element;
 503       end if;
 504
 505       return Cursor'(Container'Unrestricted_Access, T.First);
 506    end First;
 507
 508    -------------------
 509    -- First_Element --
 510    -------------------
 511
 512    function First_Element (Container : Map) return Element_Type is
 513       T : Tree_Type renames Container.Tree;
 514
 515    begin
 516       if T.First = null then
 517          raise Constraint_Error with "map is empty";
 518       end if;
 519
 520       return T.First.Element.all;
 521    end First_Element;
 522
 523    ---------------
 524    -- First_Key --
 525    ---------------
 526
 527    function First_Key (Container : Map) return Key_Type is
 528       T : Tree_Type renames Container.Tree;
 529
 530    begin
 531       if T.First = null then
 532          raise Constraint_Error with "map is empty";
 533       end if;
 534
 535       return T.First.Key.all;
 536    end First_Key;
 537
 538    -----------
 539    -- Floor --
 540    -----------
 541
 542    function Floor (Container : Map; Key : Key_Type) return Cursor is
 543       Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key);
 544
 545    begin
 546       if Node = null then
 547          return No_Element;
 548       end if;
 549
 550       return Cursor'(Container'Unrestricted_Access, Node);
 551    end Floor;
 552
 553    ----------
 554    -- Free --
 555    ----------
 556
 557    procedure Free (X : in out Node_Access) is
 558       procedure Deallocate is
 559         new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 560
 561    begin
 562       if X = null then
 563          return;
 564       end if;
 565
 566       X.Parent := X;
 567       X.Left := X;
 568       X.Right := X;
 569
 570       begin
 571          Free_Key (X.Key);
 572       exception
 573          when others =>
 574             X.Key := null;
 575
 576             begin
 577                Free_Element (X.Element);
 578             exception
 579                when others =>
 580                   X.Element := null;
 581             end;
 582
 583             Deallocate (X);
 584             raise;
 585       end;
 586
 587       begin
 588          Free_Element (X.Element);
 589       exception
 590          when others =>
 591             X.Element := null;
 592
 593             Deallocate (X);
 594             raise;
 595       end;
 596
 597       Deallocate (X);
 598    end Free;
 599
 600    -----------------
 601    -- Has_Element --
 602    -----------------
 603
 604    function Has_Element (Position : Cursor) return Boolean is
 605    begin
 606       return Position /= No_Element;
 607    end Has_Element;
 608
 609    -------------
 610    -- Include --
 611    -------------
 612
 613    procedure Include
 614      (Container : in out Map;
 615       Key       : Key_Type;
 616       New_Item  : Element_Type)
 617    is
 618       Position : Cursor;
 619       Inserted : Boolean;
 620
 621       K : Key_Access;
 622       E : Element_Access;
 623
 624    begin
 625       Insert (Container, Key, New_Item, Position, Inserted);
 626
 627       if not Inserted then
 628          if Container.Tree.Lock > 0 then
 629             raise Program_Error with
 630               "attempt to tamper with cursors (map is locked)";
 631          end if;
 632
 633          K := Position.Node.Key;
 634          E := Position.Node.Element;
 635
 636          Position.Node.Key := new Key_Type'(Key);
 637
 638          begin
 639             Position.Node.Element := new Element_Type'(New_Item);
 640          exception
 641             when others =>
 642                Free_Key (K);
 643                raise;
 644          end;
 645
 646          Free_Key (K);
 647          Free_Element (E);
 648       end if;
 649    end Include;
 650
 651    ------------
 652    -- Insert --
 653    ------------
 654
 655    procedure Insert
 656      (Container : in out Map;
 657       Key       : Key_Type;
 658       New_Item  : Element_Type;
 659       Position  : out Cursor;
 660       Inserted  : out Boolean)
 661    is
 662       function New_Node return Node_Access;
 663       pragma Inline (New_Node);
 664
 665       procedure Insert_Post is
 666         new Key_Ops.Generic_Insert_Post (New_Node);
 667
 668       procedure Insert_Sans_Hint is
 669         new Key_Ops.Generic_Conditional_Insert (Insert_Post);
 670
 671       --------------
 672       -- New_Node --
 673       --------------
 674
 675       function New_Node return Node_Access is
 676          Node : Node_Access := new Node_Type;
 677
 678       begin
 679          Node.Key := new Key_Type'(Key);
 680          Node.Element := new Element_Type'(New_Item);
 681          return Node;
 682
 683       exception
 684          when others =>
 685
 686             --  On exception, deallocate key and elem
 687
 688             Free (Node);  --  Note that Free deallocates key and elem too
 689             raise;
 690       end New_Node;
 691
 692    --  Start of processing for Insert
 693
 694    begin
 695       Insert_Sans_Hint
 696         (Container.Tree,
 697          Key,
 698          Position.Node,
 699          Inserted);
 700
 701       Position.Container := Container'Unrestricted_Access;
 702    end Insert;
 703
 704    procedure Insert
 705      (Container : in out Map;
 706       Key       : Key_Type;
 707       New_Item  : Element_Type)
 708    is
 709       Position : Cursor;
 710       pragma Unreferenced (Position);
 711
 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 : not null 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 : not null 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
1309          exception
1310             when others =>
1311                L := L - 1;
1312                B := B - 1;
1313                raise;
1314          end;
1315
1316          L := L - 1;
1317          B := B - 1;
1318       end;
1319    end Update_Element;
1320
1321    -----------
1322    -- Write --
1323    -----------
1324
1325    procedure Write
1326      (Stream    : not null access Root_Stream_Type'Class;
1327       Container : Map)
1328    is
1329       procedure Write_Node
1330         (Stream : not null access Root_Stream_Type'Class;
1331          Node   : Node_Access);
1332       pragma Inline (Write_Node);
1333
1334       procedure Write is
1335          new Tree_Operations.Generic_Write (Write_Node);
1336
1337       ----------------
1338       -- Write_Node --
1339       ----------------
1340
1341       procedure Write_Node
1342         (Stream : not null access Root_Stream_Type'Class;
1343          Node   : Node_Access)
1344       is
1345       begin
1346          Key_Type'Output (Stream, Node.Key.all);
1347          Element_Type'Output (Stream, Node.Element.all);
1348       end Write_Node;
1349
1350    --  Start of processing for Write
1351
1352    begin
1353       Write (Stream, Container.Tree);
1354    end Write;
1355
1356    procedure Write
1357      (Stream : not null access Root_Stream_Type'Class;
1358       Item   : Cursor)
1359    is
1360    begin
1361       raise Program_Error with "attempt to stream map cursor";
1362    end Write;
1363
1364 end Ada.Containers.Indefinite_Ordered_Maps;