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