gcc/ada/a-cforma.adb

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