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-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
  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    ---------
  41    -- "&" --
  42    ---------
  43
  44    function "&" (Left, Right : Vector) return Vector is
  45       LN : constant Count_Type := Length (Left);
  46       RN : constant Count_Type := Length (Right);
  47
  48    begin
  49       if LN = 0 then
  50          if RN = 0 then
  51             return Empty_Vector;
  52          end if;
  53
  54          declare
  55             E : constant Elements_Array (1 .. Length (Right)) :=
  56                   Right.Elements (1 .. RN);
  57          begin
  58             return (Length (Right), E, Last => Right.Last, others => <>);
  59          end;
  60       end if;
  61
  62       if RN = 0 then
  63          declare
  64             E : constant Elements_Array (1 .. Length (Left)) :=
  65                   Left.Elements (1 .. LN);
  66          begin
  67             return (Length (Left), E, Last => Left.Last, others => <>);
  68          end;
  69       end if;
  70
  71       declare
  72          N           : constant Int'Base := Int (LN) + Int (RN);
  73          Last_As_Int : Int'Base;
  74
  75       begin
  76          if Int (No_Index) > Int'Last - N then
  77             raise Constraint_Error with "new length is out of range";
  78          end if;
  79
  80          Last_As_Int := Int (No_Index) + N;
  81
  82          if Last_As_Int > Int (Index_Type'Last) then
  83             raise Constraint_Error with "new length is out of range";
  84          end if;
  85
  86          --  TODO: should check whether length > max capacity (cnt_t'last)  ???
  87
  88          declare
  89             Last : constant Index_Type := Index_Type (Last_As_Int);
  90
  91             LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN);
  92             RE : Elements_Array renames Right.Elements (1 .. RN);
  93
  94             Capacity : constant Count_Type := Length (Left) + Length (Right);
  95
  96          begin
  97             return (Capacity, LE & RE, Last => Last, others => <>);
  98          end;
  99       end;
 100    end "&";
 101
 102    function "&" (Left  : Vector; Right : Element_Type) return Vector is
 103       LN          : constant Count_Type := Length (Left);
 104       Last_As_Int : Int'Base;
 105
 106    begin
 107       if LN = 0 then
 108          return (1, (1 .. 1 => Right), Index_Type'First, others => <>);
 109       end if;
 110
 111       if Int (Index_Type'First) > Int'Last - Int (LN) then
 112          raise Constraint_Error with "new length is out of range";
 113       end if;
 114
 115       Last_As_Int := Int (Index_Type'First) + Int (LN);
 116
 117       if Last_As_Int > Int (Index_Type'Last) then
 118          raise Constraint_Error with "new length is out of range";
 119       end if;
 120
 121       declare
 122          Last : constant Index_Type := Index_Type (Last_As_Int);
 123          LE   : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN);
 124
 125          Capacity : constant Count_Type := Length (Left) + 1;
 126
 127       begin
 128          return (Capacity, LE & Right, Last => Last, others => <>);
 129       end;
 130    end "&";
 131
 132    function "&" (Left  : Element_Type; Right : Vector) return Vector is
 133       RN          : constant Count_Type := Length (Right);
 134       Last_As_Int : Int'Base;
 135
 136    begin
 137       if RN = 0 then
 138          return (1, (1 .. 1 => Left),
 139                  Index_Type'First, others => <>);
 140       end if;
 141
 142       if Int (Index_Type'First) > Int'Last - Int (RN) then
 143          raise Constraint_Error with "new length is out of range";
 144       end if;
 145
 146       Last_As_Int := Int (Index_Type'First) + Int (RN);
 147
 148       if Last_As_Int > Int (Index_Type'Last) then
 149          raise Constraint_Error with "new length is out of range";
 150       end if;
 151
 152       declare
 153          Last     : constant Index_Type := Index_Type (Last_As_Int);
 154          RE       : Elements_Array renames Right.Elements (1 .. RN);
 155          Capacity : constant Count_Type := 1 + Length (Right);
 156       begin
 157          return (Capacity, Left & RE, Last => Last, others => <>);
 158       end;
 159    end "&";
 160
 161    function "&" (Left, Right : Element_Type) return Vector is
 162    begin
 163       if Index_Type'First >= Index_Type'Last then
 164          raise Constraint_Error with "new length is out of range";
 165       end if;
 166
 167       declare
 168          Last : constant Index_Type := Index_Type'First + 1;
 169       begin
 170          return (2, (Left, Right), Last => Last, others => <>);
 171       end;
 172    end "&";
 173
 174    ---------
 175    -- "=" --
 176    ---------
 177
 178    function "=" (Left, Right : Vector) return Boolean is
 179    begin
 180       if Left'Address = Right'Address then
 181          return True;
 182       end if;
 183
 184       if Length (Left) /= Length (Right) then
 185          return False;
 186       end if;
 187
 188       for J in Count_Type range 1 .. Length (Left) loop
 189          if Get_Element (Left, J) /= Get_Element (Right, J) then
 190             return False;
 191          end if;
 192       end loop;
 193
 194       return True;
 195    end "=";
 196
 197    ------------
 198    -- Append --
 199    ------------
 200
 201    procedure Append (Container : in out Vector; New_Item : Vector) is
 202    begin
 203       if Is_Empty (New_Item) then
 204          return;
 205       end if;
 206
 207       if Container.Last = Index_Type'Last then
 208          raise Constraint_Error with "vector is already at its maximum length";
 209       end if;
 210
 211       Insert (Container, Container.Last + 1, New_Item);
 212    end Append;
 213
 214    procedure Append
 215      (Container : in out Vector;
 216       New_Item  : Element_Type;
 217       Count     : Count_Type := 1)
 218    is
 219    begin
 220       if Count = 0 then
 221          return;
 222       end if;
 223
 224       if Container.Last = Index_Type'Last then
 225          raise Constraint_Error with "vector is already at its maximum length";
 226       end if;
 227
 228       --  TODO: should check whether length > max capacity (cnt_t'last)  ???
 229
 230       Insert (Container, Container.Last + 1, New_Item, Count);
 231    end Append;
 232
 233    ------------
 234    -- Assign --
 235    ------------
 236
 237    procedure Assign (Target : in out Vector; Source : Vector) is
 238       LS : constant Count_Type := Length (Source);
 239
 240    begin
 241       if Target'Address = Source'Address then
 242          return;
 243       end if;
 244
 245       if Target.Capacity < LS then
 246          raise Constraint_Error;
 247       end if;
 248
 249       Target.Clear;
 250
 251       Target.Elements (1 .. LS) := Source.Elements (1 .. LS);
 252       Target.Last := Source.Last;
 253    end Assign;
 254
 255    --------------
 256    -- Capacity --
 257    --------------
 258
 259    function Capacity (Container : Vector) return Capacity_Subtype is
 260    begin
 261       return Container.Elements'Length;
 262    end Capacity;
 263
 264    -----------
 265    -- Clear --
 266    -----------
 267
 268    procedure Clear (Container : in out Vector) is
 269    begin
 270       if Container.Busy > 0 then
 271          raise Program_Error with
 272            "attempt to tamper with elements (vector is busy)";
 273       end if;
 274
 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 : Capacity_Subtype := 0) return Vector
 297    is
 298       LS : constant Count_Type := Length (Source);
 299       C  : Capacity_Subtype;
 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       if Container.Busy > 0 then
 343          raise Program_Error with
 344            "attempt to tamper with elements (vector is busy)";
 345       end if;
 346
 347       declare
 348          I_As_Int        : constant Int := Int (Index);
 349          Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
 350
 351          Count1 : constant Int'Base := Count_Type'Pos (Count);
 352          Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
 353          N      : constant Int'Base := Int'Min (Count1, Count2);
 354
 355          J_As_Int : constant Int'Base := I_As_Int + N;
 356
 357       begin
 358          if J_As_Int > Old_Last_As_Int then
 359             Container.Last := Index - 1;
 360
 361          else
 362             declare
 363                EA : Elements_Array renames Container.Elements;
 364
 365                II : constant Int'Base := I_As_Int - Int (No_Index);
 366                I  : constant Count_Type := Count_Type (II);
 367
 368                JJ : constant Int'Base := J_As_Int - Int (No_Index);
 369                J  : constant Count_Type := Count_Type (JJ);
 370
 371                New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
 372                New_Last        : constant Index_Type :=
 373                                    Index_Type (New_Last_As_Int);
 374
 375                KK : constant Int := New_Last_As_Int - Int (No_Index);
 376                K  : constant Count_Type := Count_Type (KK);
 377
 378             begin
 379                EA (I .. K) := EA (J .. Length (Container));
 380                Container.Last := New_Last;
 381             end;
 382          end if;
 383       end;
 384    end Delete;
 385
 386    procedure Delete
 387      (Container : in out Vector;
 388       Position  : in out Cursor;
 389       Count     : Count_Type := 1)
 390    is
 391    begin
 392       if not Position.Valid then
 393          raise Constraint_Error with "Position cursor has no element";
 394       end if;
 395
 396       if Position.Index > Container.Last then
 397          raise Program_Error with "Position index is out of range";
 398       end if;
 399
 400       Delete (Container, Position.Index, Count);
 401       Position := No_Element;
 402    end Delete;
 403
 404    ------------------
 405    -- Delete_First --
 406    ------------------
 407
 408    procedure Delete_First
 409      (Container : in out Vector;
 410       Count     : Count_Type := 1)
 411    is
 412    begin
 413       if Count = 0 then
 414          return;
 415       end if;
 416
 417       if Count >= Length (Container) then
 418          Clear (Container);
 419          return;
 420       end if;
 421
 422       Delete (Container, Index_Type'First, Count);
 423    end Delete_First;
 424
 425    -----------------
 426    -- Delete_Last --
 427    -----------------
 428
 429    procedure Delete_Last
 430      (Container : in out Vector;
 431       Count     : Count_Type := 1)
 432    is
 433       Index : Int'Base;
 434
 435    begin
 436       if Count = 0 then
 437          return;
 438       end if;
 439
 440       if Container.Busy > 0 then
 441          raise Program_Error with
 442            "attempt to tamper with elements (vector is busy)";
 443       end if;
 444
 445       Index := Int'Base (Container.Last) - Int'Base (Count);
 446
 447       if Index < Index_Type'Pos (Index_Type'First) then
 448          Container.Last := No_Index;
 449       else
 450          Container.Last := Index_Type (Index);
 451       end if;
 452    end Delete_Last;
 453
 454    -------------
 455    -- Element --
 456    -------------
 457
 458    function Element
 459      (Container : Vector;
 460       Index     : Index_Type) return Element_Type
 461    is
 462    begin
 463       if Index > Container.Last then
 464          raise Constraint_Error with "Index is out of range";
 465       end if;
 466
 467       declare
 468          II : constant Int'Base := Int (Index) - Int (No_Index);
 469          I  : constant Count_Type := Count_Type (II);
 470       begin
 471          return Get_Element (Container, I);
 472       end;
 473    end Element;
 474
 475    function Element
 476      (Container : Vector;
 477       Position  : Cursor) return Element_Type
 478    is
 479       Lst : constant Index_Type := Last_Index (Container);
 480
 481    begin
 482       if not Position.Valid then
 483          raise Constraint_Error with "Position cursor has no element";
 484       end if;
 485
 486       if Position.Index > Lst then
 487          raise Constraint_Error with "Position cursor is out of range";
 488       end if;
 489
 490       declare
 491          II : constant Int'Base := Int (Position.Index) - Int (No_Index);
 492          I  : constant Count_Type := Count_Type (II);
 493       begin
 494          return Get_Element (Container, I);
 495       end;
 496    end Element;
 497
 498    ----------
 499    -- Find --
 500    ----------
 501
 502    function Find
 503      (Container : Vector;
 504       Item      : Element_Type;
 505       Position  : Cursor := No_Element) return Cursor
 506    is
 507       K    : Count_Type;
 508       Last : constant Index_Type := Last_Index (Container);
 509
 510    begin
 511       if Position.Valid then
 512          if Position.Index > Last_Index (Container) then
 513             raise Program_Error with "Position index is out of range";
 514          end if;
 515       end if;
 516
 517       K := Count_Type (Int (Position.Index) - Int (No_Index));
 518
 519       for J in Position.Index .. Last loop
 520          if Get_Element (Container, K) = Item then
 521             return Cursor'(Index => J, others => <>);
 522          end if;
 523
 524          K := K + 1;
 525       end loop;
 526
 527       return No_Element;
 528    end Find;
 529
 530    ----------------
 531    -- Find_Index --
 532    ----------------
 533
 534    function Find_Index
 535      (Container : Vector;
 536       Item      : Element_Type;
 537       Index     : Index_Type := Index_Type'First) return Extended_Index
 538    is
 539       K    : Count_Type;
 540       Last : constant Index_Type := Last_Index (Container);
 541
 542    begin
 543
 544       K := Count_Type (Int (Index) - Int (No_Index));
 545       for Indx in Index .. Last loop
 546          if Get_Element (Container, K) = Item then
 547             return Indx;
 548          end if;
 549
 550          K := K + 1;
 551       end loop;
 552
 553       return No_Index;
 554    end Find_Index;
 555
 556    -----------
 557    -- First --
 558    -----------
 559
 560    function First (Container : Vector) return Cursor is
 561    begin
 562       if Is_Empty (Container) then
 563          return No_Element;
 564       end if;
 565
 566       return (True, Index_Type'First);
 567    end First;
 568
 569    -------------------
 570    -- First_Element --
 571    -------------------
 572
 573    function First_Element (Container : Vector) return Element_Type is
 574    begin
 575       if Is_Empty (Container) then
 576          raise Constraint_Error with "Container is empty";
 577       end if;
 578
 579       return Get_Element (Container, 1);
 580    end First_Element;
 581
 582    -----------------
 583    -- First_Index --
 584    -----------------
 585
 586    function First_Index (Container : Vector) return Index_Type is
 587       pragma Unreferenced (Container);
 588    begin
 589       return Index_Type'First;
 590    end First_Index;
 591
 592    ---------------------
 593    -- Generic_Sorting --
 594    ---------------------
 595
 596    package body Generic_Sorting is
 597
 598       ---------------
 599       -- Is_Sorted --
 600       ---------------
 601
 602       function Is_Sorted (Container : Vector) return Boolean is
 603          Last : constant Index_Type := Last_Index (Container);
 604
 605       begin
 606          if Container.Last <= Last then
 607             return True;
 608          end if;
 609
 610          declare
 611             L : constant Capacity_Subtype := Length (Container);
 612          begin
 613             for J in Count_Type range 1 .. L - 1 loop
 614                if Get_Element (Container, J + 1) <
 615                   Get_Element (Container, J)
 616                then
 617                   return False;
 618                end if;
 619             end loop;
 620          end;
 621
 622          return True;
 623       end Is_Sorted;
 624
 625       -----------
 626       -- Merge --
 627       -----------
 628
 629       procedure Merge (Target, Source : in out Vector) is
 630       begin
 631
 632          declare
 633             TA : Elements_Array renames Target.Elements;
 634             SA : Elements_Array renames Source.Elements;
 635
 636             I, J : Count_Type;
 637
 638          begin
 639             --  ???
 640             --           if Target.Last < Index_Type'First then
 641             --              Move (Target => Target, Source => Source);
 642             --              return;
 643             --           end if;
 644
 645             if Target'Address = Source'Address then
 646                return;
 647             end if;
 648
 649             if Source.Last < Index_Type'First then
 650                return;
 651             end if;
 652
 653             --  I think we're missing this check in a-convec.adb...  ???
 654
 655             if Target.Busy > 0 then
 656                raise Program_Error with
 657                  "attempt to tamper with elements (vector is busy)";
 658             end if;
 659
 660             if Source.Busy > 0 then
 661                raise Program_Error with
 662                  "attempt to tamper with elements (vector is busy)";
 663             end if;
 664
 665             I := Length (Target);
 666             Target.Set_Length (I + Length (Source));
 667
 668             J := Length (Target);
 669             while not Source.Is_Empty loop
 670                pragma Assert (Length (Source) <= 1
 671                  or else not (SA (Length (Source)) <
 672                      SA (Length (Source) - 1)));
 673
 674                if I = 0 then
 675                   TA (1 .. J) := SA (1 .. Length (Source));
 676                   Source.Last := No_Index;
 677                   return;
 678                end if;
 679
 680                pragma Assert (I <= 1 or else not (TA (I) < TA (I - 1)));
 681
 682                if SA (Length (Source)) < TA (I) then
 683                   TA (J) := TA (I);
 684                   I := I - 1;
 685
 686                else
 687                   TA (J) := SA (Length (Source));
 688                   Source.Last := Source.Last - 1;
 689                end if;
 690
 691                J := J - 1;
 692             end loop;
 693          end;
 694       end Merge;
 695
 696       ----------
 697       -- Sort --
 698       ----------
 699
 700       procedure Sort (Container : in out Vector)
 701       is
 702          procedure Sort is
 703            new Generic_Array_Sort
 704              (Index_Type   => Count_Type,
 705               Element_Type => Element_Type,
 706               Array_Type   => Elements_Array,
 707               "<"          => "<");
 708
 709       begin
 710          if Container.Last <= Index_Type'First then
 711             return;
 712          end if;
 713
 714          if Container.Lock > 0 then
 715             raise Program_Error with
 716               "attempt to tamper with cursors (vector is locked)";
 717          end if;
 718
 719          Sort (Container.Elements (1 .. Length (Container)));
 720       end Sort;
 721
 722    end Generic_Sorting;
 723
 724    -----------------
 725    -- Get_Element --
 726    -----------------
 727
 728    function Get_Element
 729      (Container : Vector;
 730       Position  : Count_Type) return Element_Type
 731    is
 732    begin
 733       return Container.Elements (Position);
 734    end Get_Element;
 735
 736    -----------------
 737    -- Has_Element --
 738    -----------------
 739
 740    function Has_Element
 741      (Container : Vector;
 742       Position  : Cursor) return Boolean
 743    is
 744    begin
 745       if not Position.Valid then
 746          return False;
 747       else
 748          return Position.Index <= Last_Index (Container);
 749       end if;
 750    end Has_Element;
 751
 752    ------------
 753    -- Insert --
 754    ------------
 755
 756    procedure Insert
 757      (Container : in out Vector;
 758       Before    : Extended_Index;
 759       New_Item  : Element_Type;
 760       Count     : Count_Type := 1)
 761    is
 762       N : constant Int := Count_Type'Pos (Count);
 763
 764       First           : constant Int := Int (Index_Type'First);
 765       New_Last_As_Int : Int'Base;
 766       New_Last        : Index_Type;
 767       New_Length      : UInt;
 768       Max_Length      : constant UInt := UInt (Container.Capacity);
 769
 770    begin
 771       if Before < Index_Type'First then
 772          raise Constraint_Error with
 773            "Before index is out of range (too small)";
 774       end if;
 775
 776       if Before > Container.Last
 777         and then Before > Container.Last + 1
 778       then
 779          raise Constraint_Error with
 780            "Before index is out of range (too large)";
 781       end if;
 782
 783       if Count = 0 then
 784          return;
 785       end if;
 786
 787       declare
 788          Old_Last_As_Int : constant Int := Int (Container.Last);
 789
 790       begin
 791          if Old_Last_As_Int > Int'Last - N then
 792             raise Constraint_Error with "new length is out of range";
 793          end if;
 794
 795          New_Last_As_Int := Old_Last_As_Int + N;
 796
 797          if New_Last_As_Int > Int (Index_Type'Last) then
 798             raise Constraint_Error with "new length is out of range";
 799          end if;
 800
 801          New_Length := UInt (New_Last_As_Int - First + Int'(1));
 802
 803          if New_Length > Max_Length then
 804             raise Constraint_Error with "new length is out of range";
 805          end if;
 806
 807          New_Last := Index_Type (New_Last_As_Int);
 808
 809          --  Resolve issue of capacity vs. max index  ???
 810       end;
 811
 812       if Container.Busy > 0 then
 813          raise Program_Error with
 814            "attempt to tamper with elements (vector is busy)";
 815       end if;
 816
 817       declare
 818          EA : Elements_Array renames Container.Elements;
 819
 820          BB : constant Int'Base := Int (Before) - Int (No_Index);
 821          B  : constant Count_Type := Count_Type (BB);
 822
 823          LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
 824          L  : constant Count_Type := Count_Type (LL);
 825
 826       begin
 827          if Before <= Container.Last then
 828             declare
 829                II : constant Int'Base := BB + N;
 830                I  : constant Count_Type := Count_Type (II);
 831             begin
 832                EA (I .. L) := EA (B .. Length (Container));
 833                EA (B .. I - 1) := (others => New_Item);
 834             end;
 835
 836          else
 837             EA (B .. L) := (others => New_Item);
 838          end if;
 839       end;
 840
 841       Container.Last := New_Last;
 842    end Insert;
 843
 844    procedure Insert
 845      (Container : in out Vector;
 846       Before    : Extended_Index;
 847       New_Item  : Vector)
 848    is
 849       N : constant Count_Type := Length (New_Item);
 850
 851    begin
 852       if Before < Index_Type'First then
 853          raise Constraint_Error with
 854            "Before index is out of range (too small)";
 855       end if;
 856
 857       if Before > Container.Last
 858         and then Before > Container.Last + 1
 859       then
 860          raise Constraint_Error with
 861            "Before index is out of range (too large)";
 862       end if;
 863
 864       if N = 0 then
 865          return;
 866       end if;
 867
 868       Insert_Space (Container, Before, Count => N);
 869
 870       declare
 871          Dst_Last_As_Int : constant Int'Base :=
 872                              Int (Before) + Int (N) - 1 - Int (No_Index);
 873
 874          Dst_Last : constant Count_Type := Count_Type (Dst_Last_As_Int);
 875
 876          BB : constant Int'Base := Int (Before) - Int (No_Index);
 877          B  : constant Count_Type := Count_Type (BB);
 878
 879       begin
 880          if Container'Address /= New_Item'Address then
 881             Container.Elements (B .. Dst_Last) := New_Item.Elements (1 .. N);
 882             return;
 883          end if;
 884
 885          declare
 886             Src : Elements_Array renames Container.Elements (1 .. B - 1);
 887
 888             Index_As_Int : constant Int'Base := BB + Src'Length - 1;
 889
 890             Index : constant Count_Type := Count_Type (Index_As_Int);
 891
 892             Dst : Elements_Array renames Container.Elements (B .. Index);
 893
 894          begin
 895             Dst := Src;
 896          end;
 897
 898          if Dst_Last = Length (Container) then
 899             return;
 900          end if;
 901
 902          declare
 903             Src : Elements_Array renames
 904                     Container.Elements (Dst_Last + 1 .. Length (Container));
 905
 906             Index_As_Int : constant Int'Base :=
 907                              Dst_Last_As_Int - Src'Length + 1;
 908
 909             Index : constant Count_Type := Count_Type (Index_As_Int);
 910
 911             Dst : Elements_Array renames
 912                     Container.Elements (Index .. Dst_Last);
 913
 914          begin
 915             Dst := Src;
 916          end;
 917       end;
 918    end Insert;
 919
 920    procedure Insert
 921      (Container : in out Vector;
 922       Before    : Cursor;
 923       New_Item  : Vector)
 924    is
 925       Index : Index_Type'Base;
 926
 927    begin
 928       if Is_Empty (New_Item) then
 929          return;
 930       end if;
 931
 932       if not Before.Valid
 933         or else Before.Index > Container.Last
 934       then
 935          if Container.Last = Index_Type'Last then
 936             raise Constraint_Error with
 937               "vector is already at its maximum length";
 938          end if;
 939
 940          Index := Container.Last + 1;
 941
 942       else
 943          Index := Before.Index;
 944       end if;
 945
 946       Insert (Container, Index, New_Item);
 947    end Insert;
 948
 949    procedure Insert
 950      (Container : in out Vector;
 951       Before    : Cursor;
 952       New_Item  : Vector;
 953       Position  : out Cursor)
 954    is
 955       Index : Index_Type'Base;
 956
 957    begin
 958       if Is_Empty (New_Item) then
 959          if not Before.Valid
 960            or else Before.Index > Container.Last
 961          then
 962             Position := No_Element;
 963          else
 964             Position := (True, Before.Index);
 965          end if;
 966
 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);
 985
 986       Position := Cursor'(True, Index);
 987    end Insert;
 988
 989    procedure Insert
 990      (Container : in out Vector;
 991       Before    : Cursor;
 992       New_Item  : Element_Type;
 993       Count     : Count_Type := 1)
 994    is
 995       Index : Index_Type'Base;
 996
 997    begin
 998       if Count = 0 then
 999          return;
1000       end if;
1001
1002       if not Before.Valid
1003         or else Before.Index > Container.Last
1004       then
1005          if Container.Last = Index_Type'Last then
1006             raise Constraint_Error with
1007               "vector is already at its maximum length";
1008          end if;
1009
1010          Index := Container.Last + 1;
1011
1012       else
1013          Index := Before.Index;
1014       end if;
1015
1016       Insert (Container, Index, New_Item, Count);
1017    end Insert;
1018
1019    procedure Insert
1020      (Container : in out Vector;
1021       Before    : Cursor;
1022       New_Item  : Element_Type;
1023       Position  : out Cursor;
1024       Count     : Count_Type := 1)
1025    is
1026       Index : Index_Type'Base;
1027
1028    begin
1029       if Count = 0 then
1030          if not Before.Valid
1031            or else Before.Index > Container.Last
1032          then
1033             Position := No_Element;
1034          else
1035             Position := (True, Before.Index);
1036          end if;
1037
1038          return;
1039       end if;
1040
1041       if not Before.Valid
1042         or else Before.Index > Container.Last
1043       then
1044          if Container.Last = Index_Type'Last then
1045             raise Constraint_Error with
1046               "vector is already at its maximum length";
1047          end if;
1048
1049          Index := Container.Last + 1;
1050
1051       else
1052          Index := Before.Index;
1053       end if;
1054
1055       Insert (Container, Index, New_Item, Count);
1056
1057       Position := Cursor'(True, Index);
1058    end Insert;
1059
1060    procedure Insert
1061      (Container : in out Vector;
1062       Before    : Extended_Index;
1063       Count     : Count_Type := 1)
1064    is
1065       New_Item : Element_Type;  -- Default-initialized value
1066       pragma Warnings (Off, New_Item);
1067
1068    begin
1069       Insert (Container, Before, New_Item, Count);
1070    end Insert;
1071
1072    procedure Insert
1073      (Container : in out Vector;
1074       Before    : Cursor;
1075       Position  : out Cursor;
1076       Count     : Count_Type := 1)
1077    is
1078       New_Item : Element_Type;  -- Default-initialized value
1079       pragma Warnings (Off, New_Item);
1080    begin
1081       Insert (Container, Before, New_Item, Position, Count);
1082    end Insert;
1083
1084    ------------------
1085    -- Insert_Space --
1086    ------------------
1087
1088    procedure Insert_Space
1089      (Container : in out Vector;
1090       Before    : Extended_Index;
1091       Count     : Count_Type := 1)
1092    is
1093       N : constant Int := Count_Type'Pos (Count);
1094
1095       First           : constant Int := Int (Index_Type'First);
1096       New_Last_As_Int : Int'Base;
1097       New_Last        : Index_Type;
1098       New_Length      : UInt;
1099       Max_Length      : constant UInt := UInt (Count_Type'Last);
1100
1101    begin
1102       if Before < Index_Type'First then
1103          raise Constraint_Error with
1104            "Before index is out of range (too small)";
1105       end if;
1106
1107       if Before > Container.Last
1108         and then Before > Container.Last + 1
1109       then
1110          raise Constraint_Error with
1111            "Before index is out of range (too large)";
1112       end if;
1113
1114       if Count = 0 then
1115          return;
1116       end if;
1117
1118       declare
1119          Old_Last_As_Int : constant Int := Int (Container.Last);
1120
1121       begin
1122          if Old_Last_As_Int > Int'Last - N then
1123             raise Constraint_Error with "new length is out of range";
1124          end if;
1125
1126          New_Last_As_Int := Old_Last_As_Int + N;
1127
1128          if New_Last_As_Int > Int (Index_Type'Last) then
1129             raise Constraint_Error with "new length is out of range";
1130          end if;
1131
1132          New_Length := UInt (New_Last_As_Int - First + Int'(1));
1133
1134          if New_Length > Max_Length then
1135             raise Constraint_Error with "new length is out of range";
1136          end if;
1137
1138          New_Last := Index_Type (New_Last_As_Int);
1139
1140          --  Resolve issue of capacity vs. max index  ???
1141       end;
1142
1143       if Container.Busy > 0 then
1144          raise Program_Error with
1145            "attempt to tamper with elements (vector is busy)";
1146       end if;
1147
1148       declare
1149          EA : Elements_Array renames Container.Elements;
1150
1151          BB : constant Int'Base := Int (Before) - Int (No_Index);
1152          B  : constant Count_Type := Count_Type (BB);
1153
1154          LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
1155          L  : constant Count_Type := Count_Type (LL);
1156
1157       begin
1158          if Before <= Container.Last then
1159             declare
1160                II : constant Int'Base := BB + N;
1161                I  : constant Count_Type := Count_Type (II);
1162             begin
1163                EA (I .. L) := EA (B .. Length (Container));
1164             end;
1165          end if;
1166       end;
1167
1168       Container.Last := New_Last;
1169    end Insert_Space;
1170
1171    procedure Insert_Space
1172      (Container : in out Vector;
1173       Before    : Cursor;
1174       Position  : out Cursor;
1175       Count     : Count_Type := 1)
1176    is
1177       Index : Index_Type'Base;
1178
1179    begin
1180       if Count = 0 then
1181          if not Before.Valid
1182            or else Before.Index > Container.Last
1183          then
1184             Position := No_Element;
1185          else
1186             Position := (True, Before.Index);
1187          end if;
1188
1189          return;
1190       end if;
1191
1192       if not Before.Valid
1193         or else Before.Index > Container.Last
1194       then
1195          if Container.Last = Index_Type'Last then
1196             raise Constraint_Error with
1197               "vector is already at its maximum length";
1198          end if;
1199
1200          Index := Container.Last + 1;
1201
1202       else
1203          Index := Before.Index;
1204       end if;
1205
1206       Insert_Space (Container, Index, Count => Count);
1207
1208       Position := Cursor'(True, Index);
1209    end Insert_Space;
1210
1211    --------------
1212    -- Is_Empty --
1213    --------------
1214
1215    function Is_Empty (Container : Vector) return Boolean is
1216    begin
1217       return Last_Index (Container) < Index_Type'First;
1218    end Is_Empty;
1219
1220    -------------
1221    -- Iterate --
1222    -------------
1223
1224    procedure Iterate
1225      (Container : Vector;
1226       Process   :
1227         not null access procedure (Container : Vector; Position : Cursor))
1228    is
1229       V : Vector renames Container'Unrestricted_Access.all;
1230       B : Natural renames V.Busy;
1231
1232    begin
1233       B := B + 1;
1234
1235       begin
1236          for Indx in Index_Type'First .. Last_Index (Container) loop
1237             Process (Container, Cursor'(True, Indx));
1238          end loop;
1239       exception
1240          when others =>
1241             B := B - 1;
1242             raise;
1243       end;
1244
1245       B := B - 1;
1246    end Iterate;
1247
1248    ----------
1249    -- Last --
1250    ----------
1251
1252    function Last (Container : Vector) return Cursor is
1253    begin
1254       if Is_Empty (Container) then
1255          return No_Element;
1256       end if;
1257
1258       return (True, Last_Index (Container));
1259    end Last;
1260
1261    ------------------
1262    -- Last_Element --
1263    ------------------
1264
1265    function Last_Element (Container : Vector) return Element_Type is
1266    begin
1267       if Is_Empty (Container) then
1268          raise Constraint_Error with "Container is empty";
1269       end if;
1270
1271       return Get_Element (Container, Length (Container));
1272    end Last_Element;
1273
1274    ----------------
1275    -- Last_Index --
1276    ----------------
1277
1278    function Last_Index (Container : Vector) return Extended_Index is
1279    begin
1280       return Container.Last;
1281    end Last_Index;
1282
1283    ------------
1284    -- Length --
1285    ------------
1286
1287    function Length (Container : Vector) return Capacity_Subtype is
1288       L : constant Int := Int (Last_Index (Container));
1289       F : constant Int := Int (Index_Type'First);
1290       N : constant Int'Base := L - F + 1;
1291
1292    begin
1293       return Capacity_Subtype (N);
1294    end Length;
1295
1296    ----------
1297    -- Left --
1298    ----------
1299
1300    function Left (Container : Vector; Position : Cursor) return Vector is
1301       C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
1302
1303    begin
1304       if Position = No_Element then
1305          return C;
1306       end if;
1307
1308       if not Has_Element (Container, Position) then
1309          raise Constraint_Error;
1310       end if;
1311
1312       while C.Last /= Position.Index - 1 loop
1313          Delete_Last (C);
1314       end loop;
1315       return C;
1316    end Left;
1317
1318    ----------
1319    -- Move --
1320    ----------
1321
1322    procedure Move
1323      (Target : in out Vector;
1324       Source : in out Vector)
1325    is
1326       N : constant Count_Type := Length (Source);
1327
1328    begin
1329
1330       if Target'Address = Source'Address then
1331          return;
1332       end if;
1333
1334       if Target.Busy > 0 then
1335          raise Program_Error with
1336            "attempt to tamper with elements (Target is busy)";
1337       end if;
1338
1339       if Source.Busy > 0 then
1340          raise Program_Error with
1341            "attempt to tamper with elements (Source is busy)";
1342       end if;
1343
1344       if N > Target.Capacity then
1345          raise Constraint_Error with  -- correct exception here???
1346            "length of Source is greater than capacity of Target";
1347       end if;
1348
1349       --  We could also write this as a loop, and incrementally
1350       --  copy elements from source to target.
1351
1352       Target.Last := No_Index;  -- in case array assignment files
1353       Target.Elements (1 .. N) := Source.Elements (1 .. N);
1354
1355       Target.Last := Source.Last;
1356       Source.Last := No_Index;
1357    end Move;
1358
1359    ----------
1360    -- Next --
1361    ----------
1362
1363    function Next (Container : Vector; Position : Cursor) return Cursor is
1364    begin
1365       if not Position.Valid then
1366          return No_Element;
1367       end if;
1368
1369       if Position.Index < Last_Index (Container) then
1370          return (True, Position.Index + 1);
1371       end if;
1372
1373       return No_Element;
1374    end Next;
1375
1376    ----------
1377    -- Next --
1378    ----------
1379
1380    procedure Next (Container : Vector; Position : in out Cursor) is
1381    begin
1382       if not Position.Valid then
1383          return;
1384       end if;
1385
1386       if Position.Index < Last_Index (Container) then
1387          Position.Index := Position.Index + 1;
1388       else
1389          Position := No_Element;
1390       end if;
1391    end Next;
1392
1393    -------------
1394    -- Prepend --
1395    -------------
1396
1397    procedure Prepend (Container : in out Vector; New_Item : Vector) is
1398    begin
1399       Insert (Container, Index_Type'First, New_Item);
1400    end Prepend;
1401
1402    procedure Prepend
1403      (Container : in out Vector;
1404       New_Item  : Element_Type;
1405       Count     : Count_Type := 1)
1406    is
1407    begin
1408       Insert (Container,
1409               Index_Type'First,
1410               New_Item,
1411               Count);
1412    end Prepend;
1413
1414    --------------
1415    -- Previous --
1416    --------------
1417
1418    procedure Previous (Container : Vector; Position : in out Cursor) is
1419    begin
1420       if not Position.Valid then
1421          return;
1422       end if;
1423
1424       if Position.Index > Index_Type'First and
1425         Position.Index <= Last_Index (Container) then
1426          Position.Index := Position.Index - 1;
1427       else
1428          Position := No_Element;
1429       end if;
1430    end Previous;
1431
1432    function Previous (Container : Vector; Position : Cursor) return Cursor is
1433    begin
1434       if not Position.Valid then
1435          return No_Element;
1436       end if;
1437
1438       if Position.Index > Index_Type'First and
1439         Position.Index <= Last_Index (Container) then
1440          return (True, Position.Index - 1);
1441       end if;
1442
1443       return No_Element;
1444    end Previous;
1445
1446    -------------------
1447    -- Query_Element --
1448    -------------------
1449
1450    procedure Query_Element
1451      (Container : Vector;
1452       Index     : Index_Type;
1453       Process   : not null access procedure (Element : Element_Type))
1454    is
1455       V : Vector renames Container'Unrestricted_Access.all;
1456       B : Natural renames V.Busy;
1457       L : Natural renames V.Lock;
1458
1459    begin
1460       if Index > Last_Index (Container) then
1461          raise Constraint_Error with "Index is out of range";
1462       end if;
1463
1464       B := B + 1;
1465       L := L + 1;
1466
1467       declare
1468          II : constant Int'Base := Int (Index) - Int (No_Index);
1469          I  : constant Count_Type := Count_Type (II);
1470
1471       begin
1472          Process (Get_Element (V, I));
1473       exception
1474          when others =>
1475             L := L - 1;
1476             B := B - 1;
1477             raise;
1478       end;
1479
1480       L := L - 1;
1481       B := B - 1;
1482    end Query_Element;
1483
1484    procedure Query_Element
1485      (Container : Vector;
1486       Position  : Cursor;
1487       Process   : not null access procedure (Element : Element_Type))
1488    is
1489    begin
1490       if not Position.Valid then
1491          raise Constraint_Error with "Position cursor has no element";
1492       end if;
1493
1494       Query_Element (Container, Position.Index, Process);
1495    end Query_Element;
1496
1497    ----------
1498    -- Read --
1499    ----------
1500
1501    procedure Read
1502      (Stream    : not null access Root_Stream_Type'Class;
1503       Container : out Vector)
1504    is
1505       Length : Count_Type'Base;
1506       Last   : Index_Type'Base := No_Index;
1507
1508    begin
1509       Clear (Container);
1510
1511       Count_Type'Base'Read (Stream, Length);
1512
1513       if Length < 0 then
1514          raise Program_Error with "stream appears to be corrupt";
1515       end if;
1516
1517       if Length > Container.Capacity then
1518          raise Storage_Error with "not enough capacity";  --  ???
1519       end if;
1520
1521       for J in Count_Type range 1 .. Length loop
1522          Last := Last + 1;
1523          Element_Type'Read (Stream, Container.Elements (J));
1524          Container.Last := Last;
1525       end loop;
1526    end Read;
1527
1528    procedure Read
1529      (Stream   : not null access Root_Stream_Type'Class;
1530       Position : out Cursor)
1531    is
1532    begin
1533       raise Program_Error with "attempt to stream vector cursor";
1534    end Read;
1535
1536    ---------------------
1537    -- Replace_Element --
1538    ---------------------
1539
1540    procedure Replace_Element
1541      (Container : in out Vector;
1542       Index     : Index_Type;
1543       New_Item  : Element_Type)
1544    is
1545    begin
1546
1547       if Index > Container.Last then
1548          raise Constraint_Error with "Index is out of range";
1549       end if;
1550
1551       if Container.Lock > 0 then
1552          raise Program_Error with
1553            "attempt to tamper with cursors (vector is locked)";
1554       end if;
1555
1556       declare
1557          II : constant Int'Base := Int (Index) - Int (No_Index);
1558          I  : constant Count_Type := Count_Type (II);
1559
1560       begin
1561          Container.Elements (I) := New_Item;
1562       end;
1563    end Replace_Element;
1564
1565    procedure Replace_Element
1566      (Container : in out Vector;
1567       Position  : Cursor;
1568       New_Item  : Element_Type)
1569    is
1570    begin
1571
1572       if not Position.Valid then
1573          raise Constraint_Error with "Position cursor has no element";
1574       end if;
1575
1576       if Position.Index > Container.Last then
1577          raise Constraint_Error with "Position cursor is out of range";
1578       end if;
1579
1580       if Container.Lock > 0 then
1581          raise Program_Error with
1582            "attempt to tamper with cursors (vector is locked)";
1583       end if;
1584
1585       declare
1586          II : constant Int'Base := Int (Position.Index) - Int (No_Index);
1587          I  : constant Count_Type := Count_Type (II);
1588       begin
1589          Container.Elements (I) := New_Item;
1590       end;
1591    end Replace_Element;
1592
1593    ----------------------
1594    -- Reserve_Capacity --
1595    ----------------------
1596
1597    procedure Reserve_Capacity
1598      (Container : in out Vector;
1599       Capacity  : Capacity_Subtype)
1600    is
1601    begin
1602       if Capacity > Container.Capacity then
1603          raise Constraint_Error;  -- ???
1604       end if;
1605    end Reserve_Capacity;
1606
1607    ----------------------
1608    -- Reverse_Elements --
1609    ----------------------
1610
1611    procedure Reverse_Elements (Container : in out Vector) is
1612    begin
1613       if Length (Container) <= 1 then
1614          return;
1615       end if;
1616
1617       if Container.Lock > 0 then
1618          raise Program_Error with
1619            "attempt to tamper with cursors (vector is locked)";
1620       end if;
1621
1622       declare
1623          I, J : Count_Type;
1624          E    : Elements_Array renames Container.Elements;
1625
1626       begin
1627          I := 1;
1628          J := Length (Container);
1629          while I < J loop
1630             declare
1631                EI : constant Element_Type := E (I);
1632             begin
1633                E (I) := E (J);
1634                E (J) := EI;
1635             end;
1636
1637             I := I + 1;
1638             J := J - 1;
1639          end loop;
1640       end;
1641    end Reverse_Elements;
1642
1643    ------------------
1644    -- Reverse_Find --
1645    ------------------
1646
1647    function Reverse_Find
1648      (Container : Vector;
1649       Item      : Element_Type;
1650       Position  : Cursor := No_Element) return Cursor
1651    is
1652       Last : Index_Type'Base;
1653       K    : Count_Type;
1654
1655    begin
1656       if not Position.Valid
1657         or else Position.Index > Last_Index (Container)
1658       then
1659          Last := Last_Index (Container);
1660       else
1661          Last := Position.Index;
1662       end if;
1663
1664       K := Count_Type (Int (Last) - Int (No_Index));
1665       for Indx in reverse Index_Type'First .. Last loop
1666          if Get_Element (Container, K) = Item then
1667             return (True, Indx);
1668          end if;
1669
1670          K := K - 1;
1671       end loop;
1672
1673       return No_Element;
1674    end Reverse_Find;
1675
1676    ------------------------
1677    -- Reverse_Find_Index --
1678    ------------------------
1679
1680    function Reverse_Find_Index
1681      (Container : Vector;
1682       Item      : Element_Type;
1683       Index     : Index_Type := Index_Type'Last) return Extended_Index
1684    is
1685       Last : Index_Type'Base;
1686       K    : Count_Type;
1687
1688    begin
1689       if Index > Last_Index (Container) then
1690          Last := Last_Index (Container);
1691       else
1692          Last := Index;
1693       end if;
1694
1695       K := Count_Type (Int (Last) - Int (No_Index));
1696       for Indx in reverse Index_Type'First .. Last loop
1697          if Get_Element (Container, K) = Item then
1698             return Indx;
1699          end if;
1700
1701          K := K - 1;
1702       end loop;
1703
1704       return No_Index;
1705    end Reverse_Find_Index;
1706
1707    ---------------------
1708    -- Reverse_Iterate --
1709    ---------------------
1710
1711    procedure Reverse_Iterate
1712      (Container : Vector;
1713       Process   : not null access procedure (Container : Vector;
1714                                              Position : Cursor))
1715    is
1716       V : Vector renames Container'Unrestricted_Access.all;
1717       B : Natural renames V.Busy;
1718
1719    begin
1720       B := B + 1;
1721
1722       begin
1723          for Indx in reverse Index_Type'First .. Last_Index (Container) loop
1724             Process (Container, Cursor'(True, Indx));
1725          end loop;
1726       exception
1727          when others =>
1728             B := B - 1;
1729             raise;
1730       end;
1731
1732       B := B - 1;
1733    end Reverse_Iterate;
1734
1735    -----------
1736    -- Right --
1737    -----------
1738
1739    function Right (Container : Vector; Position : Cursor) return Vector is
1740       C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
1741
1742    begin
1743       if Position = No_Element then
1744          Clear (C);
1745          return C;
1746       end if;
1747
1748       if not Has_Element (Container, Position) then
1749          raise Constraint_Error;
1750       end if;
1751
1752       while C.Last /= Container.Last - Position.Index + 1 loop
1753          Delete_First (C);
1754       end loop;
1755
1756       return C;
1757    end Right;
1758
1759    ----------------
1760    -- Set_Length --
1761    ----------------
1762
1763    procedure Set_Length
1764      (Container : in out Vector;
1765       Length    : Capacity_Subtype)
1766    is
1767    begin
1768       if Length = Formal_Vectors.Length (Container) then
1769          return;
1770       end if;
1771
1772       if Container.Busy > 0 then
1773          raise Program_Error with
1774            "attempt to tamper with elements (vector is busy)";
1775       end if;
1776
1777       if Length > Container.Capacity then
1778          raise Constraint_Error;  -- ???
1779       end if;
1780
1781       declare
1782          Last_As_Int : constant Int'Base :=
1783                          Int (Index_Type'First) + Int (Length) - 1;
1784       begin
1785          Container.Last := Index_Type'Base (Last_As_Int);
1786       end;
1787    end Set_Length;
1788
1789    ----------
1790    -- Swap --
1791    ----------
1792
1793    procedure Swap (Container : in out Vector; I, J : Index_Type) is
1794    begin
1795       if I > Container.Last then
1796          raise Constraint_Error with "I index is out of range";
1797       end if;
1798
1799       if J > Container.Last then
1800          raise Constraint_Error with "J index is out of range";
1801       end if;
1802
1803       if I = J then
1804          return;
1805       end if;
1806
1807       if Container.Lock > 0 then
1808          raise Program_Error with
1809            "attempt to tamper with cursors (vector is locked)";
1810       end if;
1811
1812       declare
1813          II : constant Int'Base := Int (I) - Int (No_Index);
1814          JJ : constant Int'Base := Int (J) - Int (No_Index);
1815
1816          EI : Element_Type renames Container.Elements (Count_Type (II));
1817          EJ : Element_Type renames Container.Elements (Count_Type (JJ));
1818
1819          EI_Copy : constant Element_Type := EI;
1820
1821       begin
1822          EI := EJ;
1823          EJ := EI_Copy;
1824       end;
1825    end Swap;
1826
1827    procedure Swap (Container : in out Vector; I, J : Cursor) is
1828    begin
1829       if not I.Valid then
1830          raise Constraint_Error with "I cursor has no element";
1831       end if;
1832
1833       if not J.Valid then
1834          raise Constraint_Error with "J cursor has no element";
1835       end if;
1836
1837       Swap (Container, I.Index, J.Index);
1838    end Swap;
1839
1840    ---------------
1841    -- To_Cursor --
1842    ---------------
1843
1844    function To_Cursor
1845      (Container : Vector;
1846       Index     : Extended_Index) return Cursor
1847    is
1848    begin
1849       if Index not in Index_Type'First .. Last_Index (Container) then
1850          return No_Element;
1851       end if;
1852
1853       return Cursor'(True, Index);
1854    end To_Cursor;
1855
1856    --------------
1857    -- To_Index --
1858    --------------
1859
1860    function To_Index (Position : Cursor) return Extended_Index is
1861    begin
1862       if not Position.Valid then
1863          return No_Index;
1864       end if;
1865
1866       return Position.Index;
1867    end To_Index;
1868
1869    ---------------
1870    -- To_Vector --
1871    ---------------
1872
1873    function To_Vector (Length : Capacity_Subtype) return Vector is
1874    begin
1875       if Length = 0 then
1876          return Empty_Vector;
1877       end if;
1878
1879       declare
1880          First       : constant Int := Int (Index_Type'First);
1881          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
1882          Last        : Index_Type;
1883
1884       begin
1885          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1886             raise Constraint_Error with "Length is out of range";  -- ???
1887          end if;
1888
1889          Last := Index_Type (Last_As_Int);
1890
1891          return (Length, (others => <>), Last => Last,
1892                  others => <>);
1893       end;
1894    end To_Vector;
1895
1896    function To_Vector
1897      (New_Item : Element_Type;
1898       Length   : Capacity_Subtype) return Vector
1899    is
1900    begin
1901       if Length = 0 then
1902          return Empty_Vector;
1903       end if;
1904
1905       declare
1906          First       : constant Int := Int (Index_Type'First);
1907          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
1908          Last        : Index_Type;
1909
1910       begin
1911          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1912             raise Constraint_Error with "Length is out of range";  -- ???
1913          end if;
1914
1915          Last := Index_Type (Last_As_Int);
1916
1917          return (Length, (others => New_Item), Last => Last,
1918                  others => <>);
1919       end;
1920    end To_Vector;
1921
1922    --------------------
1923    -- Update_Element --
1924    --------------------
1925
1926    procedure Update_Element
1927      (Container : in out Vector;
1928       Index     : Index_Type;
1929       Process   : not null access procedure (Element : in out Element_Type))
1930    is
1931       B : Natural renames Container.Busy;
1932       L : Natural renames Container.Lock;
1933
1934    begin
1935
1936       if Index > Container.Last then
1937          raise Constraint_Error with "Index is out of range";
1938       end if;
1939
1940       B := B + 1;
1941       L := L + 1;
1942
1943       declare
1944          II : constant Int'Base := Int (Index) - Int (No_Index);
1945          I  : constant Count_Type := Count_Type (II);
1946
1947       begin
1948          Process (Container.Elements (I));
1949       exception
1950          when others =>
1951             L := L - 1;
1952             B := B - 1;
1953             raise;
1954       end;
1955
1956       L := L - 1;
1957       B := B - 1;
1958    end Update_Element;
1959
1960    procedure Update_Element
1961      (Container : in out Vector;
1962       Position  : Cursor;
1963       Process   : not null access procedure (Element : in out Element_Type))
1964    is
1965    begin
1966       if not Position.Valid then
1967          raise Constraint_Error with "Position cursor has no element";
1968       end if;
1969
1970       Update_Element (Container, Position.Index, Process);
1971    end Update_Element;
1972
1973    -----------
1974    -- Write --
1975    -----------
1976
1977    procedure Write
1978      (Stream    : not null access Root_Stream_Type'Class;
1979       Container : Vector)
1980    is
1981    begin
1982       Count_Type'Base'Write (Stream, Length (Container));
1983
1984       for J in 1 .. Length (Container) loop
1985          Element_Type'Write (Stream, Container.Elements (J));
1986       end loop;
1987    end Write;
1988
1989    procedure Write
1990      (Stream   : not null access Root_Stream_Type'Class;
1991       Position : Cursor)
1992    is
1993    begin
1994       raise Program_Error with "attempt to stream vector cursor";
1995    end Write;
1996
1997 end Ada.Containers.Formal_Vectors;