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