gcc/ada/a-cborma.adb

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