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-2011, 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
  50    overriding function Last (Object : Iterator) return Cursor;
  51
  52    overriding function Next
  53      (Object   : Iterator;
  54       Position : Cursor) return Cursor;
  55
  56    overriding function Previous
  57      (Object   : Iterator;
  58       Position : Cursor) return Cursor;
  59
  60    -----------------------------
  61    -- Node Access Subprograms --
  62    -----------------------------
  63
  64    --  These subprograms provide a functional interface to access fields
  65    --  of a node, and a procedural interface for modifying these values.
  66
  67    function Color (Node : Node_Type) return Color_Type;
  68    pragma Inline (Color);
  69
  70    function Left (Node : Node_Type) return Count_Type;
  71    pragma Inline (Left);
  72
  73    function Parent (Node : Node_Type) return Count_Type;
  74    pragma Inline (Parent);
  75
  76    function Right (Node : Node_Type) return Count_Type;
  77    pragma Inline (Right);
  78
  79    procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type);
  80    pragma Inline (Set_Parent);
  81
  82    procedure Set_Left (Node : in out Node_Type; Left : Count_Type);
  83    pragma Inline (Set_Left);
  84
  85    procedure Set_Right (Node : in out Node_Type; Right : Count_Type);
  86    pragma Inline (Set_Right);
  87
  88    procedure Set_Color (Node : in out Node_Type; Color : Color_Type);
  89    pragma Inline (Set_Color);
  90
  91    -----------------------
  92    -- Local Subprograms --
  93    -----------------------
  94
  95    function Is_Greater_Key_Node
  96      (Left  : Key_Type;
  97       Right : Node_Type) return Boolean;
  98    pragma Inline (Is_Greater_Key_Node);
  99
 100    function Is_Less_Key_Node
 101      (Left  : Key_Type;
 102       Right : Node_Type) return Boolean;
 103    pragma Inline (Is_Less_Key_Node);
 104
 105    --------------------------
 106    -- Local Instantiations --
 107    --------------------------
 108
 109    package Tree_Operations is
 110       new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types);
 111
 112    use Tree_Operations;
 113
 114    package Key_Ops is
 115      new Red_Black_Trees.Generic_Bounded_Keys
 116        (Tree_Operations     => Tree_Operations,
 117         Key_Type            => Key_Type,
 118         Is_Less_Key_Node    => Is_Less_Key_Node,
 119         Is_Greater_Key_Node => Is_Greater_Key_Node);
 120
 121    ---------
 122    -- "<" --
 123    ---------
 124
 125    function "<" (Left, Right : Cursor) return Boolean is
 126    begin
 127       if Left.Node = 0 then
 128          raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
 129       end if;
 130
 131       if Right.Node = 0 then
 132          raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
 133       end if;
 134
 135       pragma Assert (Vet (Left.Container.all, Left.Node),
 136                      "Left cursor of ""<"" is bad");
 137
 138       pragma Assert (Vet (Right.Container.all, Right.Node),
 139                      "Right cursor of ""<"" is bad");
 140
 141       declare
 142          LN : Node_Type renames Left.Container.Nodes (Left.Node);
 143          RN : Node_Type renames Right.Container.Nodes (Right.Node);
 144
 145       begin
 146          return LN.Key < RN.Key;
 147       end;
 148    end "<";
 149
 150    function "<" (Left : Cursor; Right : Key_Type) return Boolean is
 151    begin
 152       if Left.Node = 0 then
 153          raise Constraint_Error with "Left cursor of ""<"" equals No_Element";
 154       end if;
 155
 156       pragma Assert (Vet (Left.Container.all, Left.Node),
 157                      "Left cursor of ""<"" is bad");
 158
 159       declare
 160          LN : Node_Type renames Left.Container.Nodes (Left.Node);
 161
 162       begin
 163          return LN.Key < Right;
 164       end;
 165    end "<";
 166
 167    function "<" (Left : Key_Type; Right : Cursor) return Boolean is
 168    begin
 169       if Right.Node = 0 then
 170          raise Constraint_Error with "Right cursor of ""<"" equals No_Element";
 171       end if;
 172
 173       pragma Assert (Vet (Right.Container.all, Right.Node),
 174                      "Right cursor of ""<"" is bad");
 175
 176       declare
 177          RN : Node_Type renames Right.Container.Nodes (Right.Node);
 178
 179       begin
 180          return Left < RN.Key;
 181       end;
 182    end "<";
 183
 184    ---------
 185    -- "=" --
 186    ---------
 187
 188    function "=" (Left, Right : Map) return Boolean is
 189       function Is_Equal_Node_Node (L, R : Node_Type) return Boolean;
 190       pragma Inline (Is_Equal_Node_Node);
 191
 192       function Is_Equal is
 193         new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
 194
 195       ------------------------
 196       -- Is_Equal_Node_Node --
 197       ------------------------
 198
 199       function Is_Equal_Node_Node
 200         (L, R : Node_Type) return Boolean is
 201       begin
 202          if L.Key < R.Key then
 203             return False;
 204
 205          elsif R.Key < L.Key then
 206             return False;
 207
 208          else
 209             return L.Element = R.Element;
 210          end if;
 211       end Is_Equal_Node_Node;
 212
 213    --  Start of processing for "="
 214
 215    begin
 216       return Is_Equal (Left, Right);
 217    end "=";
 218
 219    ---------
 220    -- ">" --
 221    ---------
 222
 223    function ">" (Left, Right : Cursor) return Boolean is
 224    begin
 225       if Left.Node = 0 then
 226          raise Constraint_Error with "Left cursor of "">"" equals No_Element";
 227       end if;
 228
 229       if Right.Node = 0 then
 230          raise Constraint_Error with "Right cursor of "">"" equals No_Element";
 231       end if;
 232
 233       pragma Assert (Vet (Left.Container.all, Left.Node),
 234                      "Left cursor of "">"" is bad");
 235
 236       pragma Assert (Vet (Right.Container.all, Right.Node),
 237                      "Right cursor of "">"" is bad");
 238
 239       declare
 240          LN : Node_Type renames Left.Container.Nodes (Left.Node);
 241          RN : Node_Type renames Right.Container.Nodes (Right.Node);
 242
 243       begin
 244          return RN.Key < LN.Key;
 245       end;
 246    end ">";
 247
 248    function ">" (Left : Cursor; Right : Key_Type) return Boolean is
 249    begin
 250       if Left.Node = 0 then
 251          raise Constraint_Error with "Left cursor of "">"" equals No_Element";
 252       end if;
 253
 254       pragma Assert (Vet (Left.Container.all, Left.Node),
 255                      "Left cursor of "">"" is bad");
 256
 257       declare
 258          LN : Node_Type renames Left.Container.Nodes (Left.Node);
 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    begin
 518       if Node = 0 then
 519          raise Constraint_Error with "key not in map";
 520       else
 521          return Container.Nodes (Node).Element;
 522       end if;
 523    end Element;
 524
 525    ---------------------
 526    -- Equivalent_Keys --
 527    ---------------------
 528
 529    function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
 530    begin
 531       if Left < Right
 532         or else Right < Left
 533       then
 534          return False;
 535       else
 536          return True;
 537       end if;
 538    end Equivalent_Keys;
 539
 540    -------------
 541    -- Exclude --
 542    -------------
 543
 544    procedure Exclude (Container : in out Map; Key : Key_Type) is
 545       X : constant Count_Type := Key_Ops.Find (Container, Key);
 546
 547    begin
 548       if X /= 0 then
 549          Tree_Operations.Delete_Node_Sans_Free (Container, X);
 550          Tree_Operations.Free (Container, X);
 551       end if;
 552    end Exclude;
 553
 554    ----------
 555    -- Find --
 556    ----------
 557
 558    function Find (Container : Map; Key : Key_Type) return Cursor is
 559       Node : constant Count_Type := Key_Ops.Find (Container, Key);
 560    begin
 561       if Node = 0 then
 562          return No_Element;
 563       else
 564          return Cursor'(Container'Unrestricted_Access, Node);
 565       end if;
 566    end Find;
 567
 568    -----------
 569    -- First --
 570    -----------
 571
 572    function First (Container : Map) return Cursor is
 573    begin
 574       if Container.First = 0 then
 575          return No_Element;
 576       else
 577          return Cursor'(Container'Unrestricted_Access, Container.First);
 578       end if;
 579    end First;
 580
 581    function First (Object : Iterator) return Cursor is
 582       F : constant Count_Type := Object.Container.First;
 583    begin
 584       if F = 0 then
 585          return No_Element;
 586       else
 587          return Cursor'(Object.Container.all'Unchecked_Access, F);
 588       end if;
 589    end First;
 590
 591    -------------------
 592    -- First_Element --
 593    -------------------
 594
 595    function First_Element (Container : Map) return Element_Type is
 596    begin
 597       if Container.First = 0 then
 598          raise Constraint_Error with "map is empty";
 599       else
 600          return Container.Nodes (Container.First).Element;
 601       end if;
 602    end First_Element;
 603
 604    ---------------
 605    -- First_Key --
 606    ---------------
 607
 608    function First_Key (Container : Map) return Key_Type is
 609    begin
 610       if Container.First = 0 then
 611          raise Constraint_Error with "map is empty";
 612       else
 613          return Container.Nodes (Container.First).Key;
 614       end if;
 615    end First_Key;
 616
 617    -----------
 618    -- Floor --
 619    -----------
 620
 621    function Floor (Container : Map; Key : Key_Type) return Cursor is
 622       Node : constant Count_Type := Key_Ops.Floor (Container, Key);
 623    begin
 624       if Node = 0 then
 625          return No_Element;
 626       else
 627          return Cursor'(Container'Unrestricted_Access, Node);
 628       end if;
 629    end Floor;
 630
 631    -----------------
 632    -- Has_Element --
 633    -----------------
 634
 635    function Has_Element (Position : Cursor) return Boolean is
 636    begin
 637       return Position /= No_Element;
 638    end Has_Element;
 639
 640    -------------
 641    -- Include --
 642    -------------
 643
 644    procedure Include
 645      (Container : in out Map;
 646       Key       : Key_Type;
 647       New_Item  : Element_Type)
 648    is
 649       Position : Cursor;
 650       Inserted : Boolean;
 651
 652    begin
 653       Insert (Container, Key, New_Item, Position, Inserted);
 654
 655       if not Inserted then
 656          if Container.Lock > 0 then
 657             raise Program_Error with
 658               "attempt to tamper with elements (map is locked)";
 659          end if;
 660
 661          declare
 662             N : Node_Type renames Container.Nodes (Position.Node);
 663          begin
 664             N.Key := Key;
 665             N.Element := New_Item;
 666          end;
 667       end if;
 668    end Include;
 669
 670    ------------
 671    -- Insert --
 672    ------------
 673
 674    procedure Insert
 675      (Container : in out Map;
 676       Key       : Key_Type;
 677       New_Item  : Element_Type;
 678       Position  : out Cursor;
 679       Inserted  : out Boolean)
 680    is
 681       procedure Assign (Node : in out Node_Type);
 682       pragma Inline (Assign);
 683
 684       function New_Node return Count_Type;
 685       pragma Inline (New_Node);
 686
 687       procedure Insert_Post is
 688         new Key_Ops.Generic_Insert_Post (New_Node);
 689
 690       procedure Insert_Sans_Hint is
 691         new Key_Ops.Generic_Conditional_Insert (Insert_Post);
 692
 693       procedure Allocate is
 694          new Tree_Operations.Generic_Allocate (Assign);
 695
 696       ------------
 697       -- Assign --
 698       ------------
 699
 700       procedure Assign (Node : in out Node_Type) is
 701       begin
 702          Node.Key := Key;
 703          Node.Element := New_Item;
 704       end Assign;
 705
 706       --------------
 707       -- New_Node --
 708       --------------
 709
 710       function New_Node return Count_Type is
 711          Result : Count_Type;
 712       begin
 713          Allocate (Container, Result);
 714          return Result;
 715       end New_Node;
 716
 717    --  Start of processing for Insert
 718
 719    begin
 720       Insert_Sans_Hint
 721         (Container,
 722          Key,
 723          Position.Node,
 724          Inserted);
 725
 726       Position.Container := Container'Unrestricted_Access;
 727    end Insert;
 728
 729    procedure Insert
 730      (Container : in out Map;
 731       Key       : Key_Type;
 732       New_Item  : Element_Type)
 733    is
 734       Position : Cursor;
 735       pragma Unreferenced (Position);
 736
 737       Inserted : Boolean;
 738
 739    begin
 740       Insert (Container, Key, New_Item, Position, Inserted);
 741
 742       if not Inserted then
 743          raise Constraint_Error with "key already in map";
 744       end if;
 745    end Insert;
 746
 747    procedure Insert
 748      (Container : in out Map;
 749       Key       : Key_Type;
 750       Position  : out Cursor;
 751       Inserted  : out Boolean)
 752    is
 753       procedure Assign (Node : in out Node_Type);
 754       pragma Inline (Assign);
 755
 756       function New_Node return Count_Type;
 757       pragma Inline (New_Node);
 758
 759       procedure Insert_Post is
 760         new Key_Ops.Generic_Insert_Post (New_Node);
 761
 762       procedure Insert_Sans_Hint is
 763         new Key_Ops.Generic_Conditional_Insert (Insert_Post);
 764
 765       procedure Allocate is
 766          new Tree_Operations.Generic_Allocate (Assign);
 767
 768       ------------
 769       -- Assign --
 770       ------------
 771
 772       procedure Assign (Node : in out Node_Type) is
 773       begin
 774          Node.Key := Key;
 775
 776          --  Were this insertion operation to accept an element parameter, this
 777          --  is the point where the element value would be used, to update the
 778          --  element component of the new node. However, this insertion
 779          --  operation is special, in the sense that it does not accept an
 780          --  element parameter. Rather, this version of Insert allocates a node
 781          --  (inserting it among the active nodes of the container in the
 782          --  normal way, with the node's position being determined by the Key),
 783          --  and passes back a cursor designating the node. It is then up to
 784          --  the caller to assign a value to the node's element.
 785
 786          --  Node.Element := New_Item;
 787       end Assign;
 788
 789       --------------
 790       -- New_Node --
 791       --------------
 792
 793       function New_Node return Count_Type is
 794          Result : Count_Type;
 795       begin
 796          Allocate (Container, Result);
 797          return Result;
 798       end New_Node;
 799
 800    --  Start of processing for Insert
 801
 802    begin
 803       Insert_Sans_Hint
 804         (Container,
 805          Key,
 806          Position.Node,
 807          Inserted);
 808
 809       Position.Container := Container'Unrestricted_Access;
 810    end Insert;
 811
 812    --------------
 813    -- Is_Empty --
 814    --------------
 815
 816    function Is_Empty (Container : Map) return Boolean is
 817    begin
 818       return Container.Length = 0;
 819    end Is_Empty;
 820
 821    -------------------------
 822    -- Is_Greater_Key_Node --
 823    -------------------------
 824
 825    function Is_Greater_Key_Node
 826      (Left  : Key_Type;
 827       Right : Node_Type) return Boolean
 828    is
 829    begin
 830       --  Left > Right same as Right < Left
 831
 832       return Right.Key < Left;
 833    end Is_Greater_Key_Node;
 834
 835    ----------------------
 836    -- Is_Less_Key_Node --
 837    ----------------------
 838
 839    function Is_Less_Key_Node
 840      (Left  : Key_Type;
 841       Right : Node_Type) return Boolean
 842    is
 843    begin
 844       return Left < Right.Key;
 845    end Is_Less_Key_Node;
 846
 847    -------------
 848    -- Iterate --
 849    -------------
 850
 851    procedure Iterate
 852      (Container : Map;
 853       Process   : not null access procedure (Position : Cursor))
 854    is
 855       procedure Process_Node (Node : Count_Type);
 856       pragma Inline (Process_Node);
 857
 858       procedure Local_Iterate is
 859          new Tree_Operations.Generic_Iteration (Process_Node);
 860
 861       ------------------
 862       -- Process_Node --
 863       ------------------
 864
 865       procedure Process_Node (Node : Count_Type) is
 866       begin
 867          Process (Cursor'(Container'Unrestricted_Access, Node));
 868       end Process_Node;
 869
 870       B : Natural renames Container'Unrestricted_Access.all.Busy;
 871
 872    --  Start of processing for Iterate
 873
 874    begin
 875       B := B + 1;
 876
 877       begin
 878          Local_Iterate (Container);
 879       exception
 880          when others =>
 881             B := B - 1;
 882             raise;
 883       end;
 884
 885       B := B - 1;
 886    end Iterate;
 887
 888    function Iterate
 889      (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class
 890    is
 891       It : constant Iterator :=
 892              (Container'Unrestricted_Access, Container.First);
 893    begin
 894       return It;
 895    end Iterate;
 896
 897    function Iterate
 898      (Container : Map;
 899       Start     : Cursor)
 900       return Map_Iterator_Interfaces.Reversible_Iterator'class
 901    is
 902       It : constant Iterator := (Container'Unrestricted_Access, Start.Node);
 903    begin
 904       return It;
 905    end Iterate;
 906
 907    ---------
 908    -- Key --
 909    ---------
 910
 911    function Key (Position : Cursor) return Key_Type is
 912    begin
 913       if Position.Node = 0 then
 914          raise Constraint_Error with
 915            "Position cursor of function Key equals No_Element";
 916       end if;
 917
 918       pragma Assert (Vet (Position.Container.all, Position.Node),
 919                      "Position cursor of function Key is bad");
 920
 921       return Position.Container.Nodes (Position.Node).Key;
 922    end Key;
 923
 924    ----------
 925    -- Last --
 926    ----------
 927
 928    function Last (Container : Map) return Cursor is
 929    begin
 930       if Container.Last = 0 then
 931          return No_Element;
 932       else
 933          return Cursor'(Container'Unrestricted_Access, Container.Last);
 934       end if;
 935    end Last;
 936
 937    function Last (Object : Iterator) return Cursor is
 938       F : constant Count_Type := Object.Container.Last;
 939    begin
 940       if F = 0 then
 941          return No_Element;
 942       else
 943          return Cursor'(Object.Container.all'Unchecked_Access, F);
 944       end if;
 945    end Last;
 946
 947    ------------------
 948    -- Last_Element --
 949    ------------------
 950
 951    function Last_Element (Container : Map) return Element_Type is
 952    begin
 953       if Container.Last = 0 then
 954          raise Constraint_Error with "map is empty";
 955       else
 956          return Container.Nodes (Container.Last).Element;
 957       end if;
 958    end Last_Element;
 959
 960    --------------
 961    -- Last_Key --
 962    --------------
 963
 964    function Last_Key (Container : Map) return Key_Type is
 965    begin
 966       if Container.Last = 0 then
 967          raise Constraint_Error with "map is empty";
 968       else
 969          return Container.Nodes (Container.Last).Key;
 970       end if;
 971    end Last_Key;
 972
 973    ----------
 974    -- Left --
 975    ----------
 976
 977    function Left (Node : Node_Type) return Count_Type is
 978    begin
 979       return Node.Left;
 980    end Left;
 981
 982    ------------
 983    -- Length --
 984    ------------
 985
 986    function Length (Container : Map) return Count_Type is
 987    begin
 988       return Container.Length;
 989    end Length;
 990
 991    ----------
 992    -- Move --
 993    ----------
 994
 995    procedure Move (Target : in out Map; Source : in out Map) is
 996    begin
 997       if Target'Address = Source'Address then
 998          return;
 999       end if;
1000
1001       if Source.Busy > 0 then
1002          raise Program_Error with
1003            "attempt to tamper with cursors (container is busy)";
1004       end if;
1005
1006       Target.Assign (Source);
1007       Source.Clear;
1008    end Move;
1009
1010    ----------
1011    -- Next --
1012    ----------
1013
1014    procedure Next (Position : in out Cursor) is
1015    begin
1016       Position := Next (Position);
1017    end Next;
1018
1019    function Next (Position : Cursor) return Cursor is
1020    begin
1021       if Position = No_Element then
1022          return No_Element;
1023       end if;
1024
1025       pragma Assert (Vet (Position.Container.all, Position.Node),
1026                      "Position cursor of Next is bad");
1027
1028       declare
1029          M : Map renames Position.Container.all;
1030
1031          Node : constant Count_Type :=
1032                   Tree_Operations.Next (M, Position.Node);
1033
1034       begin
1035          if Node = 0 then
1036             return No_Element;
1037          end if;
1038
1039          return Cursor'(Position.Container, Node);
1040       end;
1041    end Next;
1042
1043    function Next
1044      (Object   : Iterator;
1045       Position : Cursor) return Cursor
1046    is
1047       pragma Unreferenced (Object);
1048    begin
1049       return Next (Position);
1050    end Next;
1051
1052    ------------
1053    -- Parent --
1054    ------------
1055
1056    function Parent (Node : Node_Type) return Count_Type is
1057    begin
1058       return Node.Parent;
1059    end Parent;
1060
1061    --------------
1062    -- Previous --
1063    --------------
1064
1065    procedure Previous (Position : in out Cursor) is
1066    begin
1067       Position := Previous (Position);
1068    end Previous;
1069
1070    function Previous (Position : Cursor) return Cursor is
1071    begin
1072       if Position = No_Element then
1073          return No_Element;
1074       end if;
1075
1076       pragma Assert (Vet (Position.Container.all, Position.Node),
1077                      "Position cursor of Previous is bad");
1078
1079       declare
1080          M : Map renames Position.Container.all;
1081
1082          Node : constant Count_Type :=
1083                   Tree_Operations.Previous (M, Position.Node);
1084
1085       begin
1086          if Node = 0 then
1087             return No_Element;
1088          end if;
1089
1090          return Cursor'(Position.Container, Node);
1091       end;
1092    end Previous;
1093
1094    function Previous
1095      (Object   : Iterator;
1096       Position : Cursor) return Cursor
1097    is
1098       pragma Unreferenced (Object);
1099    begin
1100       return Previous (Position);
1101    end Previous;
1102
1103    -------------------
1104    -- Query_Element --
1105    -------------------
1106
1107    procedure Query_Element
1108      (Position : Cursor;
1109       Process  : not null access procedure (Key     : Key_Type;
1110                                             Element : Element_Type))
1111    is
1112    begin
1113       if Position.Node = 0 then
1114          raise Constraint_Error with
1115            "Position cursor of Query_Element equals No_Element";
1116       end if;
1117
1118       pragma Assert (Vet (Position.Container.all, Position.Node),
1119                      "Position cursor of Query_Element is bad");
1120
1121       declare
1122          M : Map renames Position.Container.all;
1123          N : Node_Type renames M.Nodes (Position.Node);
1124
1125          B : Natural renames M.Busy;
1126          L : Natural renames M.Lock;
1127
1128       begin
1129          B := B + 1;
1130          L := L + 1;
1131
1132          begin
1133             Process (N.Key, N.Element);
1134          exception
1135             when others =>
1136                L := L - 1;
1137                B := B - 1;
1138                raise;
1139          end;
1140
1141          L := L - 1;
1142          B := B - 1;
1143       end;
1144    end Query_Element;
1145
1146    ----------
1147    -- Read --
1148    ----------
1149
1150    procedure Read
1151      (Stream    : not null access Root_Stream_Type'Class;
1152       Container : out Map)
1153    is
1154       procedure Read_Element (Node : in out Node_Type);
1155       pragma Inline (Read_Element);
1156
1157       procedure Allocate is
1158          new Tree_Operations.Generic_Allocate (Read_Element);
1159
1160       procedure Read_Elements is
1161          new Tree_Operations.Generic_Read (Allocate);
1162
1163       ------------------
1164       -- Read_Element --
1165       ------------------
1166
1167       procedure Read_Element (Node : in out Node_Type) is
1168       begin
1169          Key_Type'Read (Stream, Node.Key);
1170          Element_Type'Read (Stream, Node.Element);
1171       end Read_Element;
1172
1173    --  Start of processing for Read
1174
1175    begin
1176       Read_Elements (Stream, Container);
1177    end Read;
1178
1179    procedure Read
1180      (Stream : not null access Root_Stream_Type'Class;
1181       Item   : out Cursor)
1182    is
1183    begin
1184       raise Program_Error with "attempt to stream map cursor";
1185    end Read;
1186
1187    procedure Read
1188      (Stream : not null access Root_Stream_Type'Class;
1189       Item   : out Reference_Type)
1190    is
1191    begin
1192       raise Program_Error with "attempt to stream reference";
1193    end Read;
1194
1195    procedure Read
1196      (Stream : not null access Root_Stream_Type'Class;
1197       Item   : out Constant_Reference_Type)
1198    is
1199    begin
1200       raise Program_Error with "attempt to stream reference";
1201    end Read;
1202
1203    ---------------
1204    -- Reference --
1205    ---------------
1206
1207    function Constant_Reference
1208      (Container : Map;
1209       Key       : Key_Type) return Constant_Reference_Type
1210    is
1211    begin
1212       return (Element => Container.Element (Key)'Unrestricted_Access);
1213    end Constant_Reference;
1214
1215    function Reference
1216      (Container : Map;
1217       Key       : Key_Type) return Reference_Type
1218    is
1219    begin
1220       return (Element => Container.Element (Key)'Unrestricted_Access);
1221    end Reference;
1222
1223    -------------
1224    -- Replace --
1225    -------------
1226
1227    procedure Replace
1228      (Container : in out Map;
1229       Key       : Key_Type;
1230       New_Item  : Element_Type)
1231    is
1232       Node : constant Count_Type := Key_Ops.Find (Container, Key);
1233
1234    begin
1235       if Node = 0 then
1236          raise Constraint_Error with "key not in map";
1237       end if;
1238
1239       if Container.Lock > 0 then
1240          raise Program_Error with
1241            "attempt to tamper with elements (map is locked)";
1242       end if;
1243
1244       declare
1245          N : Node_Type renames Container.Nodes (Node);
1246
1247       begin
1248          N.Key := Key;
1249          N.Element := New_Item;
1250       end;
1251    end Replace;
1252
1253    ---------------------
1254    -- Replace_Element --
1255    ---------------------
1256
1257    procedure Replace_Element
1258      (Container : in out Map;
1259       Position  : Cursor;
1260       New_Item  : Element_Type)
1261    is
1262    begin
1263       if Position.Node = 0 then
1264          raise Constraint_Error with
1265            "Position cursor of Replace_Element equals No_Element";
1266       end if;
1267
1268       if Position.Container /= Container'Unrestricted_Access then
1269          raise Program_Error with
1270            "Position cursor of Replace_Element designates wrong map";
1271       end if;
1272
1273       if Container.Lock > 0 then
1274          raise Program_Error with
1275            "attempt to tamper with elements (map is locked)";
1276       end if;
1277
1278       pragma Assert (Vet (Container, Position.Node),
1279                      "Position cursor of Replace_Element is bad");
1280
1281       Container.Nodes (Position.Node).Element := New_Item;
1282    end Replace_Element;
1283
1284    ---------------------
1285    -- Reverse_Iterate --
1286    ---------------------
1287
1288    procedure Reverse_Iterate
1289      (Container : Map;
1290       Process   : not null access procedure (Position : Cursor))
1291    is
1292       procedure Process_Node (Node : Count_Type);
1293       pragma Inline (Process_Node);
1294
1295       procedure Local_Reverse_Iterate is
1296          new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1297
1298       ------------------
1299       -- Process_Node --
1300       ------------------
1301
1302       procedure Process_Node (Node : Count_Type) is
1303       begin
1304          Process (Cursor'(Container'Unrestricted_Access, Node));
1305       end Process_Node;
1306
1307       B : Natural renames Container'Unrestricted_Access.all.Busy;
1308
1309    --  Start of processing for Reverse_Iterate
1310
1311    begin
1312       B := B + 1;
1313
1314       begin
1315          Local_Reverse_Iterate (Container);
1316       exception
1317          when others =>
1318             B := B - 1;
1319             raise;
1320       end;
1321
1322       B := B - 1;
1323    end Reverse_Iterate;
1324
1325    -----------
1326    -- Right --
1327    -----------
1328
1329    function Right (Node : Node_Type) return Count_Type is
1330    begin
1331       return Node.Right;
1332    end Right;
1333
1334    ---------------
1335    -- Set_Color --
1336    ---------------
1337
1338    procedure Set_Color
1339      (Node  : in out Node_Type;
1340       Color : Color_Type)
1341    is
1342    begin
1343       Node.Color := Color;
1344    end Set_Color;
1345
1346    --------------
1347    -- Set_Left --
1348    --------------
1349
1350    procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
1351    begin
1352       Node.Left := Left;
1353    end Set_Left;
1354
1355    ----------------
1356    -- Set_Parent --
1357    ----------------
1358
1359    procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
1360    begin
1361       Node.Parent := Parent;
1362    end Set_Parent;
1363
1364    ---------------
1365    -- Set_Right --
1366    ---------------
1367
1368    procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
1369    begin
1370       Node.Right := Right;
1371    end Set_Right;
1372
1373    --------------------
1374    -- Update_Element --
1375    --------------------
1376
1377    procedure Update_Element
1378      (Container : in out Map;
1379       Position  : Cursor;
1380       Process   : not null access procedure (Key     : Key_Type;
1381                                              Element : in out Element_Type))
1382    is
1383    begin
1384       if Position.Node = 0 then
1385          raise Constraint_Error with
1386            "Position cursor of Update_Element equals No_Element";
1387       end if;
1388
1389       if Position.Container /= Container'Unrestricted_Access then
1390          raise Program_Error with
1391            "Position cursor of Update_Element designates wrong map";
1392       end if;
1393
1394       pragma Assert (Vet (Container, Position.Node),
1395                      "Position cursor of Update_Element is bad");
1396
1397       declare
1398          N : Node_Type renames Container.Nodes (Position.Node);
1399          B : Natural renames Container.Busy;
1400          L : Natural renames Container.Lock;
1401
1402       begin
1403          B := B + 1;
1404          L := L + 1;
1405
1406          begin
1407             Process (N.Key, N.Element);
1408
1409          exception
1410             when others =>
1411                L := L - 1;
1412                B := B - 1;
1413                raise;
1414          end;
1415
1416          L := L - 1;
1417          B := B - 1;
1418       end;
1419    end Update_Element;
1420
1421    -----------
1422    -- Write --
1423    -----------
1424
1425    procedure Write
1426      (Stream    : not null access Root_Stream_Type'Class;
1427       Container : Map)
1428    is
1429       procedure Write_Node
1430         (Stream : not null access Root_Stream_Type'Class;
1431          Node   : Node_Type);
1432       pragma Inline (Write_Node);
1433
1434       procedure Write_Nodes is
1435          new Tree_Operations.Generic_Write (Write_Node);
1436
1437       ----------------
1438       -- Write_Node --
1439       ----------------
1440
1441       procedure Write_Node
1442         (Stream : not null access Root_Stream_Type'Class;
1443          Node   : Node_Type)
1444       is
1445       begin
1446          Key_Type'Write (Stream, Node.Key);
1447          Element_Type'Write (Stream, Node.Element);
1448       end Write_Node;
1449
1450    --  Start of processing for Write
1451
1452    begin
1453       Write_Nodes (Stream, Container);
1454    end Write;
1455
1456    procedure Write
1457      (Stream : not null access Root_Stream_Type'Class;
1458       Item   : Cursor)
1459    is
1460    begin
1461       raise Program_Error with "attempt to stream map cursor";
1462    end Write;
1463
1464    procedure Write
1465      (Stream : not null access Root_Stream_Type'Class;
1466       Item   : Reference_Type)
1467    is
1468    begin
1469       raise Program_Error with "attempt to stream reference";
1470    end Write;
1471
1472    procedure Write
1473      (Stream : not null access Root_Stream_Type'Class;
1474       Item   : Constant_Reference_Type)
1475    is
1476    begin
1477       raise Program_Error with "attempt to stream reference";
1478    end Write;
1479
1480 end Ada.Containers.Bounded_Ordered_Maps;