gcc/ada/a-coorma.adb

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