gomp-20050608-branch/gcc/ada/a-ciorma.adb

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