gcc/ada/a-cofove.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 _ V E C T O R S        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2010-2013, 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.Generic_Array_Sort;
  29 with System; use type System.Address;
  30
  31 package body Ada.Containers.Formal_Vectors is
  32
  33    type Int is range System.Min_Int .. System.Max_Int;
  34    type UInt is mod System.Max_Binary_Modulus;
  35
  36    function Get_Element
  37      (Container : Vector;
  38       Position  : Count_Type) return Element_Type;
  39
  40    procedure Insert_Space
  41      (Container : in out Vector;
  42       Before    : Extended_Index;
  43       Count     : Count_Type := 1);
  44
  45    ---------
  46    -- "&" --
  47    ---------
  48
  49    function "&" (Left, Right : Vector) return Vector is
  50       LN : constant Count_Type := Length (Left);
  51       RN : constant Count_Type := Length (Right);
  52
  53    begin
  54       if LN = 0 then
  55          if RN = 0 then
  56             return Empty_Vector;
  57          end if;
  58
  59          declare
  60             E : constant Elements_Array (1 .. Length (Right)) :=
  61               Right.Elements (1 .. RN);
  62          begin
  63             return (Length (Right), E, Last => Right.Last, others => <>);
  64          end;
  65       end if;
  66
  67       if RN = 0 then
  68          declare
  69             E : constant Elements_Array (1 .. Length (Left)) :=
  70               Left.Elements (1 .. LN);
  71          begin
  72             return (Length (Left), E, Last => Left.Last, others => <>);
  73          end;
  74       end if;
  75
  76       declare
  77          N           : constant Int'Base := Int (LN) + Int (RN);
  78          Last_As_Int : Int'Base;
  79
  80       begin
  81          if Int (No_Index) > Int'Last - N then
  82             raise Constraint_Error with "new length is out of range";
  83          end if;
  84
  85          Last_As_Int := Int (No_Index) + N;
  86
  87          if Last_As_Int > Int (Index_Type'Last) then
  88             raise Constraint_Error with "new length is out of range";
  89          end if;
  90
  91          --  TODO: should check whether length > max capacity (cnt_t'last)  ???
  92
  93          declare
  94             Last : constant Index_Type := Index_Type (Last_As_Int);
  95
  96             LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN);
  97             RE : Elements_Array renames Right.Elements (1 .. RN);
  98
  99             Capacity : constant Count_Type := Length (Left) + Length (Right);
 100
 101          begin
 102             return (Capacity, LE & RE, Last => Last, others => <>);
 103          end;
 104       end;
 105    end "&";
 106
 107    function "&" (Left  : Vector; Right : Element_Type) return Vector is
 108       LN          : constant Count_Type := Length (Left);
 109       Last_As_Int : Int'Base;
 110
 111    begin
 112       if LN = 0 then
 113          return (1, (1 .. 1 => Right), Index_Type'First, others => <>);
 114       end if;
 115
 116       if Int (Index_Type'First) > Int'Last - Int (LN) then
 117          raise Constraint_Error with "new length is out of range";
 118       end if;
 119
 120       Last_As_Int := Int (Index_Type'First) + Int (LN);
 121
 122       if Last_As_Int > Int (Index_Type'Last) then
 123          raise Constraint_Error with "new length is out of range";
 124       end if;
 125
 126       declare
 127          Last : constant Index_Type := Index_Type (Last_As_Int);
 128          LE   : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN);
 129
 130          Capacity : constant Count_Type := Length (Left) + 1;
 131
 132       begin
 133          return (Capacity, LE & Right, Last => Last, others => <>);
 134       end;
 135    end "&";
 136
 137    function "&" (Left  : Element_Type; Right : Vector) return Vector is
 138       RN          : constant Count_Type := Length (Right);
 139       Last_As_Int : Int'Base;
 140
 141    begin
 142       if RN = 0 then
 143          return (1, (1 .. 1 => Left),
 144                  Index_Type'First, others => <>);
 145       end if;
 146
 147       if Int (Index_Type'First) > Int'Last - Int (RN) then
 148          raise Constraint_Error with "new length is out of range";
 149       end if;
 150
 151       Last_As_Int := Int (Index_Type'First) + Int (RN);
 152
 153       if Last_As_Int > Int (Index_Type'Last) then
 154          raise Constraint_Error with "new length is out of range";
 155       end if;
 156
 157       declare
 158          Last     : constant Index_Type := Index_Type (Last_As_Int);
 159          RE       : Elements_Array renames Right.Elements (1 .. RN);
 160          Capacity : constant Count_Type := 1 + Length (Right);
 161       begin
 162          return (Capacity, Left & RE, Last => Last, others => <>);
 163       end;
 164    end "&";
 165
 166    function "&" (Left, Right : Element_Type) return Vector is
 167    begin
 168       if Index_Type'First >= Index_Type'Last then
 169          raise Constraint_Error with "new length is out of range";
 170       end if;
 171
 172       declare
 173          Last : constant Index_Type := Index_Type'First + 1;
 174       begin
 175          return (2, (Left, Right), Last => Last, others => <>);
 176       end;
 177    end "&";
 178
 179    ---------
 180    -- "=" --
 181    ---------
 182
 183    function "=" (Left, Right : Vector) return Boolean is
 184    begin
 185       if Left'Address = Right'Address then
 186          return True;
 187       end if;
 188
 189       if Length (Left) /= Length (Right) then
 190          return False;
 191       end if;
 192
 193       for J in Count_Type range 1 .. Length (Left) loop
 194          if Get_Element (Left, J) /= Get_Element (Right, J) then
 195             return False;
 196          end if;
 197       end loop;
 198
 199       return True;
 200    end "=";
 201
 202    ------------
 203    -- Append --
 204    ------------
 205
 206    procedure Append (Container : in out Vector; New_Item : Vector) is
 207    begin
 208       if Is_Empty (New_Item) then
 209          return;
 210       end if;
 211
 212       if Container.Last = Index_Type'Last then
 213          raise Constraint_Error with "vector is already at its maximum length";
 214       end if;
 215
 216       Insert (Container, Container.Last + 1, New_Item);
 217    end Append;
 218
 219    procedure Append
 220      (Container : in out Vector;
 221       New_Item  : Element_Type;
 222       Count     : Count_Type := 1)
 223    is
 224    begin
 225       if Count = 0 then
 226          return;
 227       end if;
 228
 229       if Container.Last = Index_Type'Last then
 230          raise Constraint_Error with "vector is already at its maximum length";
 231       end if;
 232
 233       --  TODO: should check whether length > max capacity (cnt_t'last)  ???
 234
 235       Insert (Container, Container.Last + 1, New_Item, Count);
 236    end Append;
 237
 238    ------------
 239    -- Assign --
 240    ------------
 241
 242    procedure Assign (Target : in out Vector; Source : Vector) is
 243       LS : constant Count_Type := Length (Source);
 244
 245    begin
 246       if Target'Address = Source'Address then
 247          return;
 248       end if;
 249
 250       if Target.Capacity < LS then
 251          raise Constraint_Error;
 252       end if;
 253
 254       Clear (Target);
 255
 256       Target.Elements (1 .. LS) := Source.Elements (1 .. LS);
 257       Target.Last := Source.Last;
 258    end Assign;
 259
 260    --------------
 261    -- Capacity --
 262    --------------
 263
 264    function Capacity (Container : Vector) return Count_Type is
 265    begin
 266       return Container.Elements'Length;
 267    end Capacity;
 268
 269    -----------
 270    -- Clear --
 271    -----------
 272
 273    procedure Clear (Container : in out Vector) is
 274    begin
 275       Container.Last := No_Index;
 276    end Clear;
 277
 278    --------------
 279    -- Contains --
 280    --------------
 281
 282    function Contains
 283      (Container : Vector;
 284       Item      : Element_Type) return Boolean
 285    is
 286    begin
 287       return Find_Index (Container, Item) /= No_Index;
 288    end Contains;
 289
 290    ----------
 291    -- Copy --
 292    ----------
 293
 294    function Copy
 295      (Source   : Vector;
 296       Capacity : Count_Type := 0) return Vector
 297    is
 298       LS : constant Count_Type := Length (Source);
 299       C  : Count_Type;
 300
 301    begin
 302       if Capacity = 0 then
 303          C := LS;
 304       elsif Capacity >= LS then
 305          C := Capacity;
 306       else
 307          raise Constraint_Error;
 308       end if;
 309
 310       return Target : Vector (C) do
 311          Target.Elements (1 .. LS) := Source.Elements (1 .. LS);
 312          Target.Last := Source.Last;
 313       end return;
 314    end Copy;
 315
 316    ------------
 317    -- Delete --
 318    ------------
 319
 320    procedure Delete
 321      (Container : in out Vector;
 322       Index     : Extended_Index;
 323       Count     : Count_Type := 1)
 324    is
 325    begin
 326       if Index < Index_Type'First then
 327          raise Constraint_Error with "Index is out of range (too small)";
 328       end if;
 329
 330       if Index > Container.Last then
 331          if Index > Container.Last + 1 then
 332             raise Constraint_Error with "Index is out of range (too large)";
 333          end if;
 334
 335          return;
 336       end if;
 337
 338       if Count = 0 then
 339          return;
 340       end if;
 341
 342       declare
 343          I_As_Int        : constant Int := Int (Index);
 344          Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
 345
 346          Count1 : constant Int'Base := Count_Type'Pos (Count);
 347          Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
 348          N      : constant Int'Base := Int'Min (Count1, Count2);
 349
 350          J_As_Int : constant Int'Base := I_As_Int + N;
 351
 352       begin
 353          if J_As_Int > Old_Last_As_Int then
 354             Container.Last := Index - 1;
 355
 356          else
 357             declare
 358                EA : Elements_Array renames Container.Elements;
 359
 360                II : constant Int'Base := I_As_Int - Int (No_Index);
 361                I  : constant Count_Type := Count_Type (II);
 362
 363                JJ : constant Int'Base := J_As_Int - Int (No_Index);
 364                J  : constant Count_Type := Count_Type (JJ);
 365
 366                New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
 367                New_Last        : constant Index_Type :=
 368                  Index_Type (New_Last_As_Int);
 369
 370                KK : constant Int := New_Last_As_Int - Int (No_Index);
 371                K  : constant Count_Type := Count_Type (KK);
 372
 373             begin
 374                EA (I .. K) := EA (J .. Length (Container));
 375                Container.Last := New_Last;
 376             end;
 377          end if;
 378       end;
 379    end Delete;
 380
 381    procedure Delete
 382      (Container : in out Vector;
 383       Position  : in out Cursor;
 384       Count     : Count_Type := 1)
 385    is
 386    begin
 387       if not Position.Valid then
 388          raise Constraint_Error with "Position cursor has no element";
 389       end if;
 390
 391       if Position.Index > Container.Last then
 392          raise Program_Error with "Position index is out of range";
 393       end if;
 394
 395       Delete (Container, Position.Index, Count);
 396       Position := No_Element;
 397    end Delete;
 398
 399    ------------------
 400    -- Delete_First --
 401    ------------------
 402
 403    procedure Delete_First
 404      (Container : in out Vector;
 405       Count     : Count_Type := 1)
 406    is
 407    begin
 408       if Count = 0 then
 409          return;
 410       end if;
 411
 412       if Count >= Length (Container) then
 413          Clear (Container);
 414          return;
 415       end if;
 416
 417       Delete (Container, Index_Type'First, Count);
 418    end Delete_First;
 419
 420    -----------------
 421    -- Delete_Last --
 422    -----------------
 423
 424    procedure Delete_Last
 425      (Container : in out Vector;
 426       Count     : Count_Type := 1)
 427    is
 428       Index : Int'Base;
 429
 430    begin
 431       if Count = 0 then
 432          return;
 433       end if;
 434
 435       Index := Int'Base (Container.Last) - Int'Base (Count);
 436
 437       if Index < Index_Type'Pos (Index_Type'First) then
 438          Container.Last := No_Index;
 439       else
 440          Container.Last := Index_Type (Index);
 441       end if;
 442    end Delete_Last;
 443
 444    -------------
 445    -- Element --
 446    -------------
 447
 448    function Element
 449      (Container : Vector;
 450       Index     : Index_Type) return Element_Type
 451    is
 452    begin
 453       if Index > Container.Last then
 454          raise Constraint_Error with "Index is out of range";
 455       end if;
 456
 457       declare
 458          II : constant Int'Base := Int (Index) - Int (No_Index);
 459          I  : constant Count_Type := Count_Type (II);
 460       begin
 461          return Get_Element (Container, I);
 462       end;
 463    end Element;
 464
 465    function Element
 466      (Container : Vector;
 467       Position  : Cursor) return Element_Type
 468    is
 469       Lst : constant Index_Type := Last_Index (Container);
 470
 471    begin
 472       if not Position.Valid then
 473          raise Constraint_Error with "Position cursor has no element";
 474       end if;
 475
 476       if Position.Index > Lst then
 477          raise Constraint_Error with "Position cursor is out of range";
 478       end if;
 479
 480       declare
 481          II : constant Int'Base := Int (Position.Index) - Int (No_Index);
 482          I  : constant Count_Type := Count_Type (II);
 483       begin
 484          return Get_Element (Container, I);
 485       end;
 486    end Element;
 487
 488    ----------
 489    -- Find --
 490    ----------
 491
 492    function Find
 493      (Container : Vector;
 494       Item      : Element_Type;
 495       Position  : Cursor := No_Element) return Cursor
 496    is
 497       K    : Count_Type;
 498       Last : constant Index_Type := Last_Index (Container);
 499
 500    begin
 501       if Position.Valid then
 502          if Position.Index > Last_Index (Container) then
 503             raise Program_Error with "Position index is out of range";
 504          end if;
 505       end if;
 506
 507       K := Count_Type (Int (Position.Index) - Int (No_Index));
 508
 509       for J in Position.Index .. Last loop
 510          if Get_Element (Container, K) = Item then
 511             return Cursor'(Index => J, others => <>);
 512          end if;
 513
 514          K := K + 1;
 515       end loop;
 516
 517       return No_Element;
 518    end Find;
 519
 520    ----------------
 521    -- Find_Index --
 522    ----------------
 523
 524    function Find_Index
 525      (Container : Vector;
 526       Item      : Element_Type;
 527       Index     : Index_Type := Index_Type'First) return Extended_Index
 528    is
 529       K    : Count_Type;
 530       Last : constant Index_Type := Last_Index (Container);
 531
 532    begin
 533       K := Count_Type (Int (Index) - Int (No_Index));
 534       for Indx in Index .. Last loop
 535          if Get_Element (Container, K) = Item then
 536             return Indx;
 537          end if;
 538
 539          K := K + 1;
 540       end loop;
 541
 542       return No_Index;
 543    end Find_Index;
 544
 545    -----------
 546    -- First --
 547    -----------
 548
 549    function First (Container : Vector) return Cursor is
 550    begin
 551       if Is_Empty (Container) then
 552          return No_Element;
 553       end if;
 554
 555       return (True, Index_Type'First);
 556    end First;
 557
 558    -------------------
 559    -- First_Element --
 560    -------------------
 561
 562    function First_Element (Container : Vector) return Element_Type is
 563    begin
 564       if Is_Empty (Container) then
 565          raise Constraint_Error with "Container is empty";
 566       end if;
 567
 568       return Get_Element (Container, 1);
 569    end First_Element;
 570
 571    -----------------
 572    -- First_Index --
 573    -----------------
 574
 575    function First_Index (Container : Vector) return Index_Type is
 576       pragma Unreferenced (Container);
 577    begin
 578       return Index_Type'First;
 579    end First_Index;
 580
 581    ---------------------
 582    -- Generic_Sorting --
 583    ---------------------
 584
 585    package body Generic_Sorting is
 586
 587       ---------------
 588       -- Is_Sorted --
 589       ---------------
 590
 591       function Is_Sorted (Container : Vector) return Boolean is
 592          Last : constant Index_Type := Last_Index (Container);
 593
 594       begin
 595          if Container.Last <= Last then
 596             return True;
 597          end if;
 598
 599          declare
 600             L : constant Count_Type := Length (Container);
 601          begin
 602             for J in Count_Type range 1 .. L - 1 loop
 603                if Get_Element (Container, J + 1) <
 604                   Get_Element (Container, J)
 605                then
 606                   return False;
 607                end if;
 608             end loop;
 609          end;
 610
 611          return True;
 612       end Is_Sorted;
 613
 614       -----------
 615       -- Merge --
 616       -----------
 617
 618       procedure Merge (Target, Source : in out Vector) is
 619       begin
 620          declare
 621             TA : Elements_Array renames Target.Elements;
 622             SA : Elements_Array renames Source.Elements;
 623
 624             I, J : Count_Type;
 625
 626          begin
 627             --  ???
 628             --           if Target.Last < Index_Type'First then
 629             --              Move (Target => Target, Source => Source);
 630             --              return;
 631             --           end if;
 632
 633             if Target'Address = Source'Address then
 634                return;
 635             end if;
 636
 637             if Source.Last < Index_Type'First then
 638                return;
 639             end if;
 640
 641             --  I think we're missing this check in a-convec.adb...  ???
 642
 643             I := Length (Target);
 644             Set_Length (Target, I + Length (Source));
 645
 646             J := Length (Target);
 647             while not Is_Empty (Source) loop
 648                pragma Assert (Length (Source) <= 1
 649                  or else not (SA (Length (Source)) <
 650                      SA (Length (Source) - 1)));
 651
 652                if I = 0 then
 653                   TA (1 .. J) := SA (1 .. Length (Source));
 654                   Source.Last := No_Index;
 655                   return;
 656                end if;
 657
 658                pragma Assert (I <= 1 or else not (TA (I) < TA (I - 1)));
 659
 660                if SA (Length (Source)) < TA (I) then
 661                   TA (J) := TA (I);
 662                   I := I - 1;
 663
 664                else
 665                   TA (J) := SA (Length (Source));
 666                   Source.Last := Source.Last - 1;
 667                end if;
 668
 669                J := J - 1;
 670             end loop;
 671          end;
 672       end Merge;
 673
 674       ----------
 675       -- Sort --
 676       ----------
 677
 678       procedure Sort (Container : in out Vector)
 679       is
 680          procedure Sort is
 681            new Generic_Array_Sort
 682              (Index_Type   => Count_Type,
 683               Element_Type => Element_Type,
 684               Array_Type   => Elements_Array,
 685               "<"          => "<");
 686
 687       begin
 688          if Container.Last <= Index_Type'First then
 689             return;
 690          end if;
 691
 692          Sort (Container.Elements (1 .. Length (Container)));
 693       end Sort;
 694
 695    end Generic_Sorting;
 696
 697    -----------------
 698    -- Get_Element --
 699    -----------------
 700
 701    function Get_Element
 702      (Container : Vector;
 703       Position  : Count_Type) return Element_Type
 704    is
 705    begin
 706       return Container.Elements (Position);
 707    end Get_Element;
 708
 709    -----------------
 710    -- Has_Element --
 711    -----------------
 712
 713    function Has_Element
 714      (Container : Vector;
 715       Position  : Cursor) return Boolean
 716    is
 717    begin
 718       if not Position.Valid then
 719          return False;
 720       else
 721          return Position.Index <= Last_Index (Container);
 722       end if;
 723    end Has_Element;
 724
 725    ------------
 726    -- Insert --
 727    ------------
 728
 729    procedure Insert
 730      (Container : in out Vector;
 731       Before    : Extended_Index;
 732       New_Item  : Element_Type;
 733       Count     : Count_Type := 1)
 734    is
 735       N : constant Int := Count_Type'Pos (Count);
 736
 737       First           : constant Int := Int (Index_Type'First);
 738       New_Last_As_Int : Int'Base;
 739       New_Last        : Index_Type;
 740       New_Length      : UInt;
 741       Max_Length      : constant UInt := UInt (Container.Capacity);
 742
 743    begin
 744       if Before < Index_Type'First then
 745          raise Constraint_Error with
 746            "Before index is out of range (too small)";
 747       end if;
 748
 749       if Before > Container.Last
 750         and then Before > Container.Last + 1
 751       then
 752          raise Constraint_Error with
 753            "Before index is out of range (too large)";
 754       end if;
 755
 756       if Count = 0 then
 757          return;
 758       end if;
 759
 760       declare
 761          Old_Last_As_Int : constant Int := Int (Container.Last);
 762
 763       begin
 764          if Old_Last_As_Int > Int'Last - N then
 765             raise Constraint_Error with "new length is out of range";
 766          end if;
 767
 768          New_Last_As_Int := Old_Last_As_Int + N;
 769
 770          if New_Last_As_Int > Int (Index_Type'Last) then
 771             raise Constraint_Error with "new length is out of range";
 772          end if;
 773
 774          New_Length := UInt (New_Last_As_Int - First + Int'(1));
 775
 776          if New_Length > Max_Length then
 777             raise Constraint_Error with "new length is out of range";
 778          end if;
 779
 780          New_Last := Index_Type (New_Last_As_Int);
 781
 782          --  Resolve issue of capacity vs. max index  ???
 783       end;
 784
 785       declare
 786          EA : Elements_Array renames Container.Elements;
 787
 788          BB : constant Int'Base := Int (Before) - Int (No_Index);
 789          B  : constant Count_Type := Count_Type (BB);
 790
 791          LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
 792          L  : constant Count_Type := Count_Type (LL);
 793
 794       begin
 795          if Before <= Container.Last then
 796             declare
 797                II : constant Int'Base := BB + N;
 798                I  : constant Count_Type := Count_Type (II);
 799             begin
 800                EA (I .. L) := EA (B .. Length (Container));
 801                EA (B .. I - 1) := (others => New_Item);
 802             end;
 803
 804          else
 805             EA (B .. L) := (others => New_Item);
 806          end if;
 807       end;
 808
 809       Container.Last := New_Last;
 810    end Insert;
 811
 812    procedure Insert
 813      (Container : in out Vector;
 814       Before    : Extended_Index;
 815       New_Item  : Vector)
 816    is
 817       N : constant Count_Type := Length (New_Item);
 818
 819    begin
 820       if Before < Index_Type'First then
 821          raise Constraint_Error with
 822            "Before index is out of range (too small)";
 823       end if;
 824
 825       if Before > Container.Last
 826         and then Before > Container.Last + 1
 827       then
 828          raise Constraint_Error with
 829            "Before index is out of range (too large)";
 830       end if;
 831
 832       if N = 0 then
 833          return;
 834       end if;
 835
 836       Insert_Space (Container, Before, Count => N);
 837
 838       declare
 839          Dst_Last_As_Int : constant Int'Base :=
 840            Int (Before) + Int (N) - 1 - Int (No_Index);
 841
 842          Dst_Last : constant Count_Type := Count_Type (Dst_Last_As_Int);
 843
 844          BB : constant Int'Base := Int (Before) - Int (No_Index);
 845          B  : constant Count_Type := Count_Type (BB);
 846
 847       begin
 848          if Container'Address /= New_Item'Address then
 849             Container.Elements (B .. Dst_Last) := New_Item.Elements (1 .. N);
 850             return;
 851          end if;
 852
 853          declare
 854             Src : Elements_Array renames Container.Elements (1 .. B - 1);
 855
 856             Index_As_Int : constant Int'Base := BB + Src'Length - 1;
 857
 858             Index : constant Count_Type := Count_Type (Index_As_Int);
 859
 860             Dst : Elements_Array renames Container.Elements (B .. Index);
 861
 862          begin
 863             Dst := Src;
 864          end;
 865
 866          if Dst_Last = Length (Container) then
 867             return;
 868          end if;
 869
 870          declare
 871             Src : Elements_Array renames
 872                     Container.Elements (Dst_Last + 1 .. Length (Container));
 873
 874             Index_As_Int : constant Int'Base :=
 875               Dst_Last_As_Int - Src'Length + 1;
 876
 877             Index : constant Count_Type := Count_Type (Index_As_Int);
 878
 879             Dst : Elements_Array renames
 880                     Container.Elements (Index .. Dst_Last);
 881
 882          begin
 883             Dst := Src;
 884          end;
 885       end;
 886    end Insert;
 887
 888    procedure Insert
 889      (Container : in out Vector;
 890       Before    : Cursor;
 891       New_Item  : Vector)
 892    is
 893       Index : Index_Type'Base;
 894
 895    begin
 896       if Is_Empty (New_Item) then
 897          return;
 898       end if;
 899
 900       if not Before.Valid
 901         or else Before.Index > Container.Last
 902       then
 903          if Container.Last = Index_Type'Last then
 904             raise Constraint_Error with
 905               "vector is already at its maximum length";
 906          end if;
 907
 908          Index := Container.Last + 1;
 909
 910       else
 911          Index := Before.Index;
 912       end if;
 913
 914       Insert (Container, Index, New_Item);
 915    end Insert;
 916
 917    procedure Insert
 918      (Container : in out Vector;
 919       Before    : Cursor;
 920       New_Item  : Vector;
 921       Position  : out Cursor)
 922    is
 923       Index : Index_Type'Base;
 924
 925    begin
 926       if Is_Empty (New_Item) then
 927          if not Before.Valid
 928            or else Before.Index > Container.Last
 929          then
 930             Position := No_Element;
 931          else
 932             Position := (True, Before.Index);
 933          end if;
 934
 935          return;
 936       end if;
 937
 938       if not Before.Valid
 939         or else Before.Index > Container.Last
 940       then
 941          if Container.Last = Index_Type'Last then
 942             raise Constraint_Error with
 943               "vector is already at its maximum length";
 944          end if;
 945
 946          Index := Container.Last + 1;
 947
 948       else
 949          Index := Before.Index;
 950       end if;
 951
 952       Insert (Container, Index, New_Item);
 953
 954       Position := Cursor'(True, Index);
 955    end Insert;
 956
 957    procedure Insert
 958      (Container : in out Vector;
 959       Before    : Cursor;
 960       New_Item  : Element_Type;
 961       Count     : Count_Type := 1)
 962    is
 963       Index : Index_Type'Base;
 964
 965    begin
 966       if Count = 0 then
 967          return;
 968       end if;
 969
 970       if not Before.Valid
 971         or else Before.Index > Container.Last
 972       then
 973          if Container.Last = Index_Type'Last then
 974             raise Constraint_Error with
 975               "vector is already at its maximum length";
 976          end if;
 977
 978          Index := Container.Last + 1;
 979
 980       else
 981          Index := Before.Index;
 982       end if;
 983
 984       Insert (Container, Index, New_Item, Count);
 985    end Insert;
 986
 987    procedure Insert
 988      (Container : in out Vector;
 989       Before    : Cursor;
 990       New_Item  : Element_Type;
 991       Position  : out Cursor;
 992       Count     : Count_Type := 1)
 993    is
 994       Index : Index_Type'Base;
 995
 996    begin
 997       if Count = 0 then
 998          if not Before.Valid
 999            or else Before.Index > Container.Last
1000          then
1001             Position := No_Element;
1002          else
1003             Position := (True, Before.Index);
1004          end if;
1005
1006          return;
1007       end if;
1008
1009       if not Before.Valid
1010         or else Before.Index > Container.Last
1011       then
1012          if Container.Last = Index_Type'Last then
1013             raise Constraint_Error with
1014               "vector is already at its maximum length";
1015          end if;
1016
1017          Index := Container.Last + 1;
1018
1019       else
1020          Index := Before.Index;
1021       end if;
1022
1023       Insert (Container, Index, New_Item, Count);
1024
1025       Position := Cursor'(True, Index);
1026    end Insert;
1027
1028    ------------------
1029    -- Insert_Space --
1030    ------------------
1031
1032    procedure Insert_Space
1033      (Container : in out Vector;
1034       Before    : Extended_Index;
1035       Count     : Count_Type := 1)
1036    is
1037       N : constant Int := Count_Type'Pos (Count);
1038
1039       First           : constant Int := Int (Index_Type'First);
1040       New_Last_As_Int : Int'Base;
1041       New_Last        : Index_Type;
1042       New_Length      : UInt;
1043       Max_Length      : constant UInt := UInt (Count_Type'Last);
1044
1045    begin
1046       if Before < Index_Type'First then
1047          raise Constraint_Error with
1048            "Before index is out of range (too small)";
1049       end if;
1050
1051       if Before > Container.Last
1052         and then Before > Container.Last + 1
1053       then
1054          raise Constraint_Error with
1055            "Before index is out of range (too large)";
1056       end if;
1057
1058       if Count = 0 then
1059          return;
1060       end if;
1061
1062       declare
1063          Old_Last_As_Int : constant Int := Int (Container.Last);
1064
1065       begin
1066          if Old_Last_As_Int > Int'Last - N then
1067             raise Constraint_Error with "new length is out of range";
1068          end if;
1069
1070          New_Last_As_Int := Old_Last_As_Int + N;
1071
1072          if New_Last_As_Int > Int (Index_Type'Last) then
1073             raise Constraint_Error with "new length is out of range";
1074          end if;
1075
1076          New_Length := UInt (New_Last_As_Int - First + Int'(1));
1077
1078          if New_Length > Max_Length then
1079             raise Constraint_Error with "new length is out of range";
1080          end if;
1081
1082          New_Last := Index_Type (New_Last_As_Int);
1083
1084          --  Resolve issue of capacity vs. max index  ???
1085       end;
1086
1087       declare
1088          EA : Elements_Array renames Container.Elements;
1089
1090          BB : constant Int'Base := Int (Before) - Int (No_Index);
1091          B  : constant Count_Type := Count_Type (BB);
1092
1093          LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
1094          L  : constant Count_Type := Count_Type (LL);
1095
1096       begin
1097          if Before <= Container.Last then
1098             declare
1099                II : constant Int'Base := BB + N;
1100                I  : constant Count_Type := Count_Type (II);
1101             begin
1102                EA (I .. L) := EA (B .. Length (Container));
1103             end;
1104          end if;
1105       end;
1106
1107       Container.Last := New_Last;
1108    end Insert_Space;
1109
1110    --------------
1111    -- Is_Empty --
1112    --------------
1113
1114    function Is_Empty (Container : Vector) return Boolean is
1115    begin
1116       return Last_Index (Container) < Index_Type'First;
1117    end Is_Empty;
1118
1119    ----------
1120    -- Last --
1121    ----------
1122
1123    function Last (Container : Vector) return Cursor is
1124    begin
1125       if Is_Empty (Container) then
1126          return No_Element;
1127       end if;
1128
1129       return (True, Last_Index (Container));
1130    end Last;
1131
1132    ------------------
1133    -- Last_Element --
1134    ------------------
1135
1136    function Last_Element (Container : Vector) return Element_Type is
1137    begin
1138       if Is_Empty (Container) then
1139          raise Constraint_Error with "Container is empty";
1140       end if;
1141
1142       return Get_Element (Container, Length (Container));
1143    end Last_Element;
1144
1145    ----------------
1146    -- Last_Index --
1147    ----------------
1148
1149    function Last_Index (Container : Vector) return Extended_Index is
1150    begin
1151       return Container.Last;
1152    end Last_Index;
1153
1154    ------------
1155    -- Length --
1156    ------------
1157
1158    function Length (Container : Vector) return Count_Type is
1159       L : constant Int := Int (Last_Index (Container));
1160       F : constant Int := Int (Index_Type'First);
1161       N : constant Int'Base := L - F + 1;
1162
1163    begin
1164       return Count_Type (N);
1165    end Length;
1166
1167    ----------
1168    -- Left --
1169    ----------
1170
1171    function Left (Container : Vector; Position : Cursor) return Vector is
1172       C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
1173
1174    begin
1175       if Position = No_Element then
1176          return C;
1177       end if;
1178
1179       if not Has_Element (Container, Position) then
1180          raise Constraint_Error;
1181       end if;
1182
1183       while C.Last /= Position.Index - 1 loop
1184          Delete_Last (C);
1185       end loop;
1186       return C;
1187    end Left;
1188
1189    ----------
1190    -- Move --
1191    ----------
1192
1193    procedure Move
1194      (Target : in out Vector;
1195       Source : in out Vector)
1196    is
1197       N : constant Count_Type := Length (Source);
1198
1199    begin
1200       if Target'Address = Source'Address then
1201          return;
1202       end if;
1203
1204       if N > Target.Capacity then
1205          raise Constraint_Error with  -- correct exception here???
1206            "length of Source is greater than capacity of Target";
1207       end if;
1208
1209       --  We could also write this as a loop, and incrementally
1210       --  copy elements from source to target.
1211
1212       Target.Last := No_Index;  -- in case array assignment files
1213       Target.Elements (1 .. N) := Source.Elements (1 .. N);
1214
1215       Target.Last := Source.Last;
1216       Source.Last := No_Index;
1217    end Move;
1218
1219    ----------
1220    -- Next --
1221    ----------
1222
1223    function Next (Container : Vector; Position : Cursor) return Cursor is
1224    begin
1225       if not Position.Valid then
1226          return No_Element;
1227       end if;
1228
1229       if Position.Index < Last_Index (Container) then
1230          return (True, Position.Index + 1);
1231       end if;
1232
1233       return No_Element;
1234    end Next;
1235
1236    ----------
1237    -- Next --
1238    ----------
1239
1240    procedure Next (Container : Vector; Position : in out Cursor) is
1241    begin
1242       if not Position.Valid then
1243          return;
1244       end if;
1245
1246       if Position.Index < Last_Index (Container) then
1247          Position.Index := Position.Index + 1;
1248       else
1249          Position := No_Element;
1250       end if;
1251    end Next;
1252
1253    -------------
1254    -- Prepend --
1255    -------------
1256
1257    procedure Prepend (Container : in out Vector; New_Item : Vector) is
1258    begin
1259       Insert (Container, Index_Type'First, New_Item);
1260    end Prepend;
1261
1262    procedure Prepend
1263      (Container : in out Vector;
1264       New_Item  : Element_Type;
1265       Count     : Count_Type := 1)
1266    is
1267    begin
1268       Insert (Container,
1269               Index_Type'First,
1270               New_Item,
1271               Count);
1272    end Prepend;
1273
1274    --------------
1275    -- Previous --
1276    --------------
1277
1278    procedure Previous (Container : Vector; Position : in out Cursor) is
1279    begin
1280       if not Position.Valid then
1281          return;
1282       end if;
1283
1284       if Position.Index > Index_Type'First and
1285         Position.Index <= Last_Index (Container) then
1286          Position.Index := Position.Index - 1;
1287       else
1288          Position := No_Element;
1289       end if;
1290    end Previous;
1291
1292    function Previous (Container : Vector; Position : Cursor) return Cursor is
1293    begin
1294       if not Position.Valid then
1295          return No_Element;
1296       end if;
1297
1298       if Position.Index > Index_Type'First and
1299         Position.Index <= Last_Index (Container) then
1300          return (True, Position.Index - 1);
1301       end if;
1302
1303       return No_Element;
1304    end Previous;
1305
1306    ---------------------
1307    -- Replace_Element --
1308    ---------------------
1309
1310    procedure Replace_Element
1311      (Container : in out Vector;
1312       Index     : Index_Type;
1313       New_Item  : Element_Type)
1314    is
1315    begin
1316       if Index > Container.Last then
1317          raise Constraint_Error with "Index is out of range";
1318       end if;
1319
1320       declare
1321          II : constant Int'Base := Int (Index) - Int (No_Index);
1322          I  : constant Count_Type := Count_Type (II);
1323
1324       begin
1325          Container.Elements (I) := New_Item;
1326       end;
1327    end Replace_Element;
1328
1329    procedure Replace_Element
1330      (Container : in out Vector;
1331       Position  : Cursor;
1332       New_Item  : Element_Type)
1333    is
1334    begin
1335       if not Position.Valid then
1336          raise Constraint_Error with "Position cursor has no element";
1337       end if;
1338
1339       if Position.Index > Container.Last then
1340          raise Constraint_Error with "Position cursor is out of range";
1341       end if;
1342
1343       declare
1344          II : constant Int'Base := Int (Position.Index) - Int (No_Index);
1345          I  : constant Count_Type := Count_Type (II);
1346       begin
1347          Container.Elements (I) := New_Item;
1348       end;
1349    end Replace_Element;
1350
1351    ----------------------
1352    -- Reserve_Capacity --
1353    ----------------------
1354
1355    procedure Reserve_Capacity
1356      (Container : in out Vector;
1357       Capacity  : Count_Type)
1358    is
1359    begin
1360       if Capacity > Container.Capacity then
1361          raise Constraint_Error with "Capacity is out of range";
1362       end if;
1363    end Reserve_Capacity;
1364
1365    ----------------------
1366    -- Reverse_Elements --
1367    ----------------------
1368
1369    procedure Reverse_Elements (Container : in out Vector) is
1370    begin
1371       if Length (Container) <= 1 then
1372          return;
1373       end if;
1374
1375       declare
1376          I, J : Count_Type;
1377          E    : Elements_Array renames Container.Elements;
1378
1379       begin
1380          I := 1;
1381          J := Length (Container);
1382          while I < J loop
1383             declare
1384                EI : constant Element_Type := E (I);
1385             begin
1386                E (I) := E (J);
1387                E (J) := EI;
1388             end;
1389
1390             I := I + 1;
1391             J := J - 1;
1392          end loop;
1393       end;
1394    end Reverse_Elements;
1395
1396    ------------------
1397    -- Reverse_Find --
1398    ------------------
1399
1400    function Reverse_Find
1401      (Container : Vector;
1402       Item      : Element_Type;
1403       Position  : Cursor := No_Element) return Cursor
1404    is
1405       Last : Index_Type'Base;
1406       K    : Count_Type;
1407
1408    begin
1409       if not Position.Valid
1410         or else Position.Index > Last_Index (Container)
1411       then
1412          Last := Last_Index (Container);
1413       else
1414          Last := Position.Index;
1415       end if;
1416
1417       K := Count_Type (Int (Last) - Int (No_Index));
1418       for Indx in reverse Index_Type'First .. Last loop
1419          if Get_Element (Container, K) = Item then
1420             return (True, Indx);
1421          end if;
1422
1423          K := K - 1;
1424       end loop;
1425
1426       return No_Element;
1427    end Reverse_Find;
1428
1429    ------------------------
1430    -- Reverse_Find_Index --
1431    ------------------------
1432
1433    function Reverse_Find_Index
1434      (Container : Vector;
1435       Item      : Element_Type;
1436       Index     : Index_Type := Index_Type'Last) return Extended_Index
1437    is
1438       Last : Index_Type'Base;
1439       K    : Count_Type;
1440
1441    begin
1442       if Index > Last_Index (Container) then
1443          Last := Last_Index (Container);
1444       else
1445          Last := Index;
1446       end if;
1447
1448       K := Count_Type (Int (Last) - Int (No_Index));
1449       for Indx in reverse Index_Type'First .. Last loop
1450          if Get_Element (Container, K) = Item then
1451             return Indx;
1452          end if;
1453
1454          K := K - 1;
1455       end loop;
1456
1457       return No_Index;
1458    end Reverse_Find_Index;
1459
1460    -----------
1461    -- Right --
1462    -----------
1463
1464    function Right (Container : Vector; Position : Cursor) return Vector is
1465       C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
1466
1467    begin
1468       if Position = No_Element then
1469          Clear (C);
1470          return C;
1471       end if;
1472
1473       if not Has_Element (Container, Position) then
1474          raise Constraint_Error;
1475       end if;
1476
1477       while C.Last /= Container.Last - Position.Index + 1 loop
1478          Delete_First (C);
1479       end loop;
1480
1481       return C;
1482    end Right;
1483
1484    ----------------
1485    -- Set_Length --
1486    ----------------
1487
1488    procedure Set_Length
1489      (Container : in out Vector;
1490       New_Length    : Count_Type)
1491    is
1492    begin
1493       if New_Length = Formal_Vectors.Length (Container) then
1494          return;
1495       end if;
1496
1497       if New_Length > Container.Capacity then
1498          raise Constraint_Error;  -- ???
1499       end if;
1500
1501       declare
1502          Last_As_Int : constant Int'Base :=
1503            Int (Index_Type'First) + Int (New_Length) - 1;
1504       begin
1505          Container.Last := Index_Type'Base (Last_As_Int);
1506       end;
1507    end Set_Length;
1508
1509    ----------
1510    -- Swap --
1511    ----------
1512
1513    procedure Swap (Container : in out Vector; I, J : Index_Type) is
1514    begin
1515       if I > Container.Last then
1516          raise Constraint_Error with "I index is out of range";
1517       end if;
1518
1519       if J > Container.Last then
1520          raise Constraint_Error with "J index is out of range";
1521       end if;
1522
1523       if I = J then
1524          return;
1525       end if;
1526
1527       declare
1528          II : constant Int'Base := Int (I) - Int (No_Index);
1529          JJ : constant Int'Base := Int (J) - Int (No_Index);
1530
1531          EI : Element_Type renames Container.Elements (Count_Type (II));
1532          EJ : Element_Type renames Container.Elements (Count_Type (JJ));
1533
1534          EI_Copy : constant Element_Type := EI;
1535
1536       begin
1537          EI := EJ;
1538          EJ := EI_Copy;
1539       end;
1540    end Swap;
1541
1542    procedure Swap (Container : in out Vector; I, J : Cursor) is
1543    begin
1544       if not I.Valid then
1545          raise Constraint_Error with "I cursor has no element";
1546       end if;
1547
1548       if not J.Valid then
1549          raise Constraint_Error with "J cursor has no element";
1550       end if;
1551
1552       Swap (Container, I.Index, J.Index);
1553    end Swap;
1554
1555    ---------------
1556    -- To_Cursor --
1557    ---------------
1558
1559    function To_Cursor
1560      (Container : Vector;
1561       Index     : Extended_Index) return Cursor
1562    is
1563    begin
1564       if Index not in Index_Type'First .. Last_Index (Container) then
1565          return No_Element;
1566       end if;
1567
1568       return Cursor'(True, Index);
1569    end To_Cursor;
1570
1571    --------------
1572    -- To_Index --
1573    --------------
1574
1575    function To_Index (Position : Cursor) return Extended_Index is
1576    begin
1577       if not Position.Valid then
1578          return No_Index;
1579       end if;
1580
1581       return Position.Index;
1582    end To_Index;
1583
1584    ---------------
1585    -- To_Vector --
1586    ---------------
1587
1588    function To_Vector
1589      (New_Item : Element_Type;
1590       Length   : Count_Type) return Vector
1591    is
1592    begin
1593       if Length = 0 then
1594          return Empty_Vector;
1595       end if;
1596
1597       declare
1598          First       : constant Int := Int (Index_Type'First);
1599          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
1600          Last        : Index_Type;
1601
1602       begin
1603          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1604             raise Constraint_Error with "Length is out of range";  -- ???
1605          end if;
1606
1607          Last := Index_Type (Last_As_Int);
1608
1609          return (Length, (others => New_Item), Last => Last,
1610                  others => <>);
1611       end;
1612    end To_Vector;
1613
1614 end Ada.Containers.Formal_Vectors;