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       K := Count_Type (Int (Index) - Int (No_Index));
 544       for Indx in Index .. Last loop
 545          if Get_Element (Container, K) = Item then
 546             return Indx;
 547          end if;
 548
 549          K := K + 1;
 550       end loop;
 551
 552       return No_Index;
 553    end Find_Index;
 554
 555    -----------
 556    -- First --
 557    -----------
 558
 559    function First (Container : Vector) return Cursor is
 560    begin
 561       if Is_Empty (Container) then
 562          return No_Element;
 563       end if;
 564
 565       return (True, Index_Type'First);
 566    end First;
 567
 568    -------------------
 569    -- First_Element --
 570    -------------------
 571
 572    function First_Element (Container : Vector) return Element_Type is
 573    begin
 574       if Is_Empty (Container) then
 575          raise Constraint_Error with "Container is empty";
 576       end if;
 577
 578       return Get_Element (Container, 1);
 579    end First_Element;
 580
 581    -----------------
 582    -- First_Index --
 583    -----------------
 584
 585    function First_Index (Container : Vector) return Index_Type is
 586       pragma Unreferenced (Container);
 587    begin
 588       return Index_Type'First;
 589    end First_Index;
 590
 591    ---------------------
 592    -- Generic_Sorting --
 593    ---------------------
 594
 595    package body Generic_Sorting is
 596
 597       ---------------
 598       -- Is_Sorted --
 599       ---------------
 600
 601       function Is_Sorted (Container : Vector) return Boolean is
 602          Last : constant Index_Type := Last_Index (Container);
 603
 604       begin
 605          if Container.Last <= Last then
 606             return True;
 607          end if;
 608
 609          declare
 610             L : constant Capacity_Subtype := Length (Container);
 611          begin
 612             for J in Count_Type range 1 .. L - 1 loop
 613                if Get_Element (Container, J + 1) <
 614                   Get_Element (Container, J)
 615                then
 616                   return False;
 617                end if;
 618             end loop;
 619          end;
 620
 621          return True;
 622       end Is_Sorted;
 623
 624       -----------
 625       -- Merge --
 626       -----------
 627
 628       procedure Merge (Target, Source : in out Vector) is
 629       begin
 630          declare
 631             TA : Elements_Array renames Target.Elements;
 632             SA : Elements_Array renames Source.Elements;
 633
 634             I, J : Count_Type;
 635
 636          begin
 637             --  ???
 638             --           if Target.Last < Index_Type'First then
 639             --              Move (Target => Target, Source => Source);
 640             --              return;
 641             --           end if;
 642
 643             if Target'Address = Source'Address then
 644                return;
 645             end if;
 646
 647             if Source.Last < Index_Type'First then
 648                return;
 649             end if;
 650
 651             --  I think we're missing this check in a-convec.adb...  ???
 652
 653             if Target.Busy > 0 then
 654                raise Program_Error with
 655                  "attempt to tamper with elements (vector is busy)";
 656             end if;
 657
 658             if Source.Busy > 0 then
 659                raise Program_Error with
 660                  "attempt to tamper with elements (vector is busy)";
 661             end if;
 662
 663             I := Length (Target);
 664             Target.Set_Length (I + Length (Source));
 665
 666             J := Length (Target);
 667             while not Source.Is_Empty loop
 668                pragma Assert (Length (Source) <= 1
 669                  or else not (SA (Length (Source)) <
 670                      SA (Length (Source) - 1)));
 671
 672                if I = 0 then
 673                   TA (1 .. J) := SA (1 .. Length (Source));
 674                   Source.Last := No_Index;
 675                   return;
 676                end if;
 677
 678                pragma Assert (I <= 1 or else not (TA (I) < TA (I - 1)));
 679
 680                if SA (Length (Source)) < TA (I) then
 681                   TA (J) := TA (I);
 682                   I := I - 1;
 683
 684                else
 685                   TA (J) := SA (Length (Source));
 686                   Source.Last := Source.Last - 1;
 687                end if;
 688
 689                J := J - 1;
 690             end loop;
 691          end;
 692       end Merge;
 693
 694       ----------
 695       -- Sort --
 696       ----------
 697
 698       procedure Sort (Container : in out Vector)
 699       is
 700          procedure Sort is
 701            new Generic_Array_Sort
 702              (Index_Type   => Count_Type,
 703               Element_Type => Element_Type,
 704               Array_Type   => Elements_Array,
 705               "<"          => "<");
 706
 707       begin
 708          if Container.Last <= Index_Type'First then
 709             return;
 710          end if;
 711
 712          if Container.Lock > 0 then
 713             raise Program_Error with
 714               "attempt to tamper with cursors (vector is locked)";
 715          end if;
 716
 717          Sort (Container.Elements (1 .. Length (Container)));
 718       end Sort;
 719
 720    end Generic_Sorting;
 721
 722    -----------------
 723    -- Get_Element --
 724    -----------------
 725
 726    function Get_Element
 727      (Container : Vector;
 728       Position  : Count_Type) return Element_Type
 729    is
 730    begin
 731       return Container.Elements (Position);
 732    end Get_Element;
 733
 734    -----------------
 735    -- Has_Element --
 736    -----------------
 737
 738    function Has_Element
 739      (Container : Vector;
 740       Position  : Cursor) return Boolean
 741    is
 742    begin
 743       if not Position.Valid then
 744          return False;
 745       else
 746          return Position.Index <= Last_Index (Container);
 747       end if;
 748    end Has_Element;
 749
 750    ------------
 751    -- Insert --
 752    ------------
 753
 754    procedure Insert
 755      (Container : in out Vector;
 756       Before    : Extended_Index;
 757       New_Item  : Element_Type;
 758       Count     : Count_Type := 1)
 759    is
 760       N : constant Int := Count_Type'Pos (Count);
 761
 762       First           : constant Int := Int (Index_Type'First);
 763       New_Last_As_Int : Int'Base;
 764       New_Last        : Index_Type;
 765       New_Length      : UInt;
 766       Max_Length      : constant UInt := UInt (Container.Capacity);
 767
 768    begin
 769       if Before < Index_Type'First then
 770          raise Constraint_Error with
 771            "Before index is out of range (too small)";
 772       end if;
 773
 774       if Before > Container.Last
 775         and then Before > Container.Last + 1
 776       then
 777          raise Constraint_Error with
 778            "Before index is out of range (too large)";
 779       end if;
 780
 781       if Count = 0 then
 782          return;
 783       end if;
 784
 785       declare
 786          Old_Last_As_Int : constant Int := Int (Container.Last);
 787
 788       begin
 789          if Old_Last_As_Int > Int'Last - N then
 790             raise Constraint_Error with "new length is out of range";
 791          end if;
 792
 793          New_Last_As_Int := Old_Last_As_Int + N;
 794
 795          if New_Last_As_Int > Int (Index_Type'Last) then
 796             raise Constraint_Error with "new length is out of range";
 797          end if;
 798
 799          New_Length := UInt (New_Last_As_Int - First + Int'(1));
 800
 801          if New_Length > Max_Length then
 802             raise Constraint_Error with "new length is out of range";
 803          end if;
 804
 805          New_Last := Index_Type (New_Last_As_Int);
 806
 807          --  Resolve issue of capacity vs. max index  ???
 808       end;
 809
 810       if Container.Busy > 0 then
 811          raise Program_Error with
 812            "attempt to tamper with elements (vector is busy)";
 813       end if;
 814
 815       declare
 816          EA : Elements_Array renames Container.Elements;
 817
 818          BB : constant Int'Base := Int (Before) - Int (No_Index);
 819          B  : constant Count_Type := Count_Type (BB);
 820
 821          LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
 822          L  : constant Count_Type := Count_Type (LL);
 823
 824       begin
 825          if Before <= Container.Last then
 826             declare
 827                II : constant Int'Base := BB + N;
 828                I  : constant Count_Type := Count_Type (II);
 829             begin
 830                EA (I .. L) := EA (B .. Length (Container));
 831                EA (B .. I - 1) := (others => New_Item);
 832             end;
 833
 834          else
 835             EA (B .. L) := (others => New_Item);
 836          end if;
 837       end;
 838
 839       Container.Last := New_Last;
 840    end Insert;
 841
 842    procedure Insert
 843      (Container : in out Vector;
 844       Before    : Extended_Index;
 845       New_Item  : Vector)
 846    is
 847       N : constant Count_Type := Length (New_Item);
 848
 849    begin
 850       if Before < Index_Type'First then
 851          raise Constraint_Error with
 852            "Before index is out of range (too small)";
 853       end if;
 854
 855       if Before > Container.Last
 856         and then Before > Container.Last + 1
 857       then
 858          raise Constraint_Error with
 859            "Before index is out of range (too large)";
 860       end if;
 861
 862       if N = 0 then
 863          return;
 864       end if;
 865
 866       Insert_Space (Container, Before, Count => N);
 867
 868       declare
 869          Dst_Last_As_Int : constant Int'Base :=
 870                              Int (Before) + Int (N) - 1 - Int (No_Index);
 871
 872          Dst_Last : constant Count_Type := Count_Type (Dst_Last_As_Int);
 873
 874          BB : constant Int'Base := Int (Before) - Int (No_Index);
 875          B  : constant Count_Type := Count_Type (BB);
 876
 877       begin
 878          if Container'Address /= New_Item'Address then
 879             Container.Elements (B .. Dst_Last) := New_Item.Elements (1 .. N);
 880             return;
 881          end if;
 882
 883          declare
 884             Src : Elements_Array renames Container.Elements (1 .. B - 1);
 885
 886             Index_As_Int : constant Int'Base := BB + Src'Length - 1;
 887
 888             Index : constant Count_Type := Count_Type (Index_As_Int);
 889
 890             Dst : Elements_Array renames Container.Elements (B .. Index);
 891
 892          begin
 893             Dst := Src;
 894          end;
 895
 896          if Dst_Last = Length (Container) then
 897             return;
 898          end if;
 899
 900          declare
 901             Src : Elements_Array renames
 902                     Container.Elements (Dst_Last + 1 .. Length (Container));
 903
 904             Index_As_Int : constant Int'Base :=
 905                              Dst_Last_As_Int - Src'Length + 1;
 906
 907             Index : constant Count_Type := Count_Type (Index_As_Int);
 908
 909             Dst : Elements_Array renames
 910                     Container.Elements (Index .. Dst_Last);
 911
 912          begin
 913             Dst := Src;
 914          end;
 915       end;
 916    end Insert;
 917
 918    procedure Insert
 919      (Container : in out Vector;
 920       Before    : Cursor;
 921       New_Item  : Vector)
 922    is
 923       Index : Index_Type'Base;
 924
 925    begin
 926       if Is_Empty (New_Item) then
 927          return;
 928       end if;
 929
 930       if not Before.Valid
 931         or else Before.Index > Container.Last
 932       then
 933          if Container.Last = Index_Type'Last then
 934             raise Constraint_Error with
 935               "vector is already at its maximum length";
 936          end if;
 937
 938          Index := Container.Last + 1;
 939
 940       else
 941          Index := Before.Index;
 942       end if;
 943
 944       Insert (Container, Index, New_Item);
 945    end Insert;
 946
 947    procedure Insert
 948      (Container : in out Vector;
 949       Before    : Cursor;
 950       New_Item  : Vector;
 951       Position  : out Cursor)
 952    is
 953       Index : Index_Type'Base;
 954
 955    begin
 956       if Is_Empty (New_Item) then
 957          if not Before.Valid
 958            or else Before.Index > Container.Last
 959          then
 960             Position := No_Element;
 961          else
 962             Position := (True, Before.Index);
 963          end if;
 964
 965          return;
 966       end if;
 967
 968       if not Before.Valid
 969         or else Before.Index > Container.Last
 970       then
 971          if Container.Last = Index_Type'Last then
 972             raise Constraint_Error with
 973               "vector is already at its maximum length";
 974          end if;
 975
 976          Index := Container.Last + 1;
 977
 978       else
 979          Index := Before.Index;
 980       end if;
 981
 982       Insert (Container, Index, New_Item);
 983
 984       Position := Cursor'(True, Index);
 985    end Insert;
 986
 987    procedure Insert
 988      (Container : in out Vector;
 989       Before    : Cursor;
 990       New_Item  : Element_Type;
 991       Count     : Count_Type := 1)
 992    is
 993       Index : Index_Type'Base;
 994
 995    begin
 996       if Count = 0 then
 997          return;
 998       end if;
 999
1000       if not Before.Valid
1001         or else Before.Index > Container.Last
1002       then
1003          if Container.Last = Index_Type'Last then
1004             raise Constraint_Error with
1005               "vector is already at its maximum length";
1006          end if;
1007
1008          Index := Container.Last + 1;
1009
1010       else
1011          Index := Before.Index;
1012       end if;
1013
1014       Insert (Container, Index, New_Item, Count);
1015    end Insert;
1016
1017    procedure Insert
1018      (Container : in out Vector;
1019       Before    : Cursor;
1020       New_Item  : Element_Type;
1021       Position  : out Cursor;
1022       Count     : Count_Type := 1)
1023    is
1024       Index : Index_Type'Base;
1025
1026    begin
1027       if Count = 0 then
1028          if not Before.Valid
1029            or else Before.Index > Container.Last
1030          then
1031             Position := No_Element;
1032          else
1033             Position := (True, Before.Index);
1034          end if;
1035
1036          return;
1037       end if;
1038
1039       if not Before.Valid
1040         or else Before.Index > Container.Last
1041       then
1042          if Container.Last = Index_Type'Last then
1043             raise Constraint_Error with
1044               "vector is already at its maximum length";
1045          end if;
1046
1047          Index := Container.Last + 1;
1048
1049       else
1050          Index := Before.Index;
1051       end if;
1052
1053       Insert (Container, Index, New_Item, Count);
1054
1055       Position := Cursor'(True, Index);
1056    end Insert;
1057
1058    procedure Insert
1059      (Container : in out Vector;
1060       Before    : Extended_Index;
1061       Count     : Count_Type := 1)
1062    is
1063       New_Item : Element_Type;  -- Default-initialized value
1064       pragma Warnings (Off, New_Item);
1065
1066    begin
1067       Insert (Container, Before, New_Item, Count);
1068    end Insert;
1069
1070    procedure Insert
1071      (Container : in out Vector;
1072       Before    : Cursor;
1073       Position  : out Cursor;
1074       Count     : Count_Type := 1)
1075    is
1076       New_Item : Element_Type;  -- Default-initialized value
1077       pragma Warnings (Off, New_Item);
1078    begin
1079       Insert (Container, Before, New_Item, Position, Count);
1080    end Insert;
1081
1082    ------------------
1083    -- Insert_Space --
1084    ------------------
1085
1086    procedure Insert_Space
1087      (Container : in out Vector;
1088       Before    : Extended_Index;
1089       Count     : Count_Type := 1)
1090    is
1091       N : constant Int := Count_Type'Pos (Count);
1092
1093       First           : constant Int := Int (Index_Type'First);
1094       New_Last_As_Int : Int'Base;
1095       New_Last        : Index_Type;
1096       New_Length      : UInt;
1097       Max_Length      : constant UInt := UInt (Count_Type'Last);
1098
1099    begin
1100       if Before < Index_Type'First then
1101          raise Constraint_Error with
1102            "Before index is out of range (too small)";
1103       end if;
1104
1105       if Before > Container.Last
1106         and then Before > Container.Last + 1
1107       then
1108          raise Constraint_Error with
1109            "Before index is out of range (too large)";
1110       end if;
1111
1112       if Count = 0 then
1113          return;
1114       end if;
1115
1116       declare
1117          Old_Last_As_Int : constant Int := Int (Container.Last);
1118
1119       begin
1120          if Old_Last_As_Int > Int'Last - N then
1121             raise Constraint_Error with "new length is out of range";
1122          end if;
1123
1124          New_Last_As_Int := Old_Last_As_Int + N;
1125
1126          if New_Last_As_Int > Int (Index_Type'Last) then
1127             raise Constraint_Error with "new length is out of range";
1128          end if;
1129
1130          New_Length := UInt (New_Last_As_Int - First + Int'(1));
1131
1132          if New_Length > Max_Length then
1133             raise Constraint_Error with "new length is out of range";
1134          end if;
1135
1136          New_Last := Index_Type (New_Last_As_Int);
1137
1138          --  Resolve issue of capacity vs. max index  ???
1139       end;
1140
1141       if Container.Busy > 0 then
1142          raise Program_Error with
1143            "attempt to tamper with elements (vector is busy)";
1144       end if;
1145
1146       declare
1147          EA : Elements_Array renames Container.Elements;
1148
1149          BB : constant Int'Base := Int (Before) - Int (No_Index);
1150          B  : constant Count_Type := Count_Type (BB);
1151
1152          LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
1153          L  : constant Count_Type := Count_Type (LL);
1154
1155       begin
1156          if Before <= Container.Last then
1157             declare
1158                II : constant Int'Base := BB + N;
1159                I  : constant Count_Type := Count_Type (II);
1160             begin
1161                EA (I .. L) := EA (B .. Length (Container));
1162             end;
1163          end if;
1164       end;
1165
1166       Container.Last := New_Last;
1167    end Insert_Space;
1168
1169    procedure Insert_Space
1170      (Container : in out Vector;
1171       Before    : Cursor;
1172       Position  : out Cursor;
1173       Count     : Count_Type := 1)
1174    is
1175       Index : Index_Type'Base;
1176
1177    begin
1178       if Count = 0 then
1179          if not Before.Valid
1180            or else Before.Index > Container.Last
1181          then
1182             Position := No_Element;
1183          else
1184             Position := (True, Before.Index);
1185          end if;
1186
1187          return;
1188       end if;
1189
1190       if not Before.Valid
1191         or else Before.Index > Container.Last
1192       then
1193          if Container.Last = Index_Type'Last then
1194             raise Constraint_Error with
1195               "vector is already at its maximum length";
1196          end if;
1197
1198          Index := Container.Last + 1;
1199
1200       else
1201          Index := Before.Index;
1202       end if;
1203
1204       Insert_Space (Container, Index, Count => Count);
1205
1206       Position := Cursor'(True, Index);
1207    end Insert_Space;
1208
1209    --------------
1210    -- Is_Empty --
1211    --------------
1212
1213    function Is_Empty (Container : Vector) return Boolean is
1214    begin
1215       return Last_Index (Container) < Index_Type'First;
1216    end Is_Empty;
1217
1218    -------------
1219    -- Iterate --
1220    -------------
1221
1222    procedure Iterate
1223      (Container : Vector;
1224       Process   :
1225         not null access procedure (Container : Vector; Position : Cursor))
1226    is
1227       V : Vector renames Container'Unrestricted_Access.all;
1228       B : Natural renames V.Busy;
1229
1230    begin
1231       B := B + 1;
1232
1233       begin
1234          for Indx in Index_Type'First .. Last_Index (Container) loop
1235             Process (Container, Cursor'(True, Indx));
1236          end loop;
1237       exception
1238          when others =>
1239             B := B - 1;
1240             raise;
1241       end;
1242
1243       B := B - 1;
1244    end Iterate;
1245
1246    ----------
1247    -- Last --
1248    ----------
1249
1250    function Last (Container : Vector) return Cursor is
1251    begin
1252       if Is_Empty (Container) then
1253          return No_Element;
1254       end if;
1255
1256       return (True, Last_Index (Container));
1257    end Last;
1258
1259    ------------------
1260    -- Last_Element --
1261    ------------------
1262
1263    function Last_Element (Container : Vector) return Element_Type is
1264    begin
1265       if Is_Empty (Container) then
1266          raise Constraint_Error with "Container is empty";
1267       end if;
1268
1269       return Get_Element (Container, Length (Container));
1270    end Last_Element;
1271
1272    ----------------
1273    -- Last_Index --
1274    ----------------
1275
1276    function Last_Index (Container : Vector) return Extended_Index is
1277    begin
1278       return Container.Last;
1279    end Last_Index;
1280
1281    ------------
1282    -- Length --
1283    ------------
1284
1285    function Length (Container : Vector) return Capacity_Subtype is
1286       L : constant Int := Int (Last_Index (Container));
1287       F : constant Int := Int (Index_Type'First);
1288       N : constant Int'Base := L - F + 1;
1289
1290    begin
1291       return Capacity_Subtype (N);
1292    end Length;
1293
1294    ----------
1295    -- Left --
1296    ----------
1297
1298    function Left (Container : Vector; Position : Cursor) return Vector is
1299       C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
1300
1301    begin
1302       if Position = No_Element then
1303          return C;
1304       end if;
1305
1306       if not Has_Element (Container, Position) then
1307          raise Constraint_Error;
1308       end if;
1309
1310       while C.Last /= Position.Index - 1 loop
1311          Delete_Last (C);
1312       end loop;
1313       return C;
1314    end Left;
1315
1316    ----------
1317    -- Move --
1318    ----------
1319
1320    procedure Move
1321      (Target : in out Vector;
1322       Source : in out Vector)
1323    is
1324       N : constant Count_Type := Length (Source);
1325
1326    begin
1327       if Target'Address = Source'Address then
1328          return;
1329       end if;
1330
1331       if Target.Busy > 0 then
1332          raise Program_Error with
1333            "attempt to tamper with elements (Target is busy)";
1334       end if;
1335
1336       if Source.Busy > 0 then
1337          raise Program_Error with
1338            "attempt to tamper with elements (Source is busy)";
1339       end if;
1340
1341       if N > Target.Capacity then
1342          raise Constraint_Error with  -- correct exception here???
1343            "length of Source is greater than capacity of Target";
1344       end if;
1345
1346       --  We could also write this as a loop, and incrementally
1347       --  copy elements from source to target.
1348
1349       Target.Last := No_Index;  -- in case array assignment files
1350       Target.Elements (1 .. N) := Source.Elements (1 .. N);
1351
1352       Target.Last := Source.Last;
1353       Source.Last := No_Index;
1354    end Move;
1355
1356    ----------
1357    -- Next --
1358    ----------
1359
1360    function Next (Container : Vector; Position : Cursor) return Cursor is
1361    begin
1362       if not Position.Valid then
1363          return No_Element;
1364       end if;
1365
1366       if Position.Index < Last_Index (Container) then
1367          return (True, Position.Index + 1);
1368       end if;
1369
1370       return No_Element;
1371    end Next;
1372
1373    ----------
1374    -- Next --
1375    ----------
1376
1377    procedure Next (Container : Vector; Position : in out Cursor) is
1378    begin
1379       if not Position.Valid then
1380          return;
1381       end if;
1382
1383       if Position.Index < Last_Index (Container) then
1384          Position.Index := Position.Index + 1;
1385       else
1386          Position := No_Element;
1387       end if;
1388    end Next;
1389
1390    -------------
1391    -- Prepend --
1392    -------------
1393
1394    procedure Prepend (Container : in out Vector; New_Item : Vector) is
1395    begin
1396       Insert (Container, Index_Type'First, New_Item);
1397    end Prepend;
1398
1399    procedure Prepend
1400      (Container : in out Vector;
1401       New_Item  : Element_Type;
1402       Count     : Count_Type := 1)
1403    is
1404    begin
1405       Insert (Container,
1406               Index_Type'First,
1407               New_Item,
1408               Count);
1409    end Prepend;
1410
1411    --------------
1412    -- Previous --
1413    --------------
1414
1415    procedure Previous (Container : Vector; Position : in out Cursor) is
1416    begin
1417       if not Position.Valid then
1418          return;
1419       end if;
1420
1421       if Position.Index > Index_Type'First and
1422         Position.Index <= Last_Index (Container) then
1423          Position.Index := Position.Index - 1;
1424       else
1425          Position := No_Element;
1426       end if;
1427    end Previous;
1428
1429    function Previous (Container : Vector; Position : Cursor) return Cursor is
1430    begin
1431       if not Position.Valid then
1432          return No_Element;
1433       end if;
1434
1435       if Position.Index > Index_Type'First and
1436         Position.Index <= Last_Index (Container) then
1437          return (True, Position.Index - 1);
1438       end if;
1439
1440       return No_Element;
1441    end Previous;
1442
1443    -------------------
1444    -- Query_Element --
1445    -------------------
1446
1447    procedure Query_Element
1448      (Container : Vector;
1449       Index     : Index_Type;
1450       Process   : not null access procedure (Element : Element_Type))
1451    is
1452       V : Vector renames Container'Unrestricted_Access.all;
1453       B : Natural renames V.Busy;
1454       L : Natural renames V.Lock;
1455
1456    begin
1457       if Index > Last_Index (Container) then
1458          raise Constraint_Error with "Index is out of range";
1459       end if;
1460
1461       B := B + 1;
1462       L := L + 1;
1463
1464       declare
1465          II : constant Int'Base := Int (Index) - Int (No_Index);
1466          I  : constant Count_Type := Count_Type (II);
1467
1468       begin
1469          Process (Get_Element (V, I));
1470       exception
1471          when others =>
1472             L := L - 1;
1473             B := B - 1;
1474             raise;
1475       end;
1476
1477       L := L - 1;
1478       B := B - 1;
1479    end Query_Element;
1480
1481    procedure Query_Element
1482      (Container : Vector;
1483       Position  : Cursor;
1484       Process   : not null access procedure (Element : Element_Type))
1485    is
1486    begin
1487       if not Position.Valid then
1488          raise Constraint_Error with "Position cursor has no element";
1489       end if;
1490
1491       Query_Element (Container, Position.Index, Process);
1492    end Query_Element;
1493
1494    ----------
1495    -- Read --
1496    ----------
1497
1498    procedure Read
1499      (Stream    : not null access Root_Stream_Type'Class;
1500       Container : out Vector)
1501    is
1502       Length : Count_Type'Base;
1503       Last   : Index_Type'Base := No_Index;
1504
1505    begin
1506       Clear (Container);
1507
1508       Count_Type'Base'Read (Stream, Length);
1509
1510       if Length < 0 then
1511          raise Program_Error with "stream appears to be corrupt";
1512       end if;
1513
1514       if Length > Container.Capacity then
1515          raise Storage_Error with "not enough capacity";  --  ???
1516       end if;
1517
1518       for J in Count_Type range 1 .. Length loop
1519          Last := Last + 1;
1520          Element_Type'Read (Stream, Container.Elements (J));
1521          Container.Last := Last;
1522       end loop;
1523    end Read;
1524
1525    procedure Read
1526      (Stream   : not null access Root_Stream_Type'Class;
1527       Position : out Cursor)
1528    is
1529    begin
1530       raise Program_Error with "attempt to stream vector cursor";
1531    end Read;
1532
1533    ---------------------
1534    -- Replace_Element --
1535    ---------------------
1536
1537    procedure Replace_Element
1538      (Container : in out Vector;
1539       Index     : Index_Type;
1540       New_Item  : Element_Type)
1541    is
1542    begin
1543       if Index > Container.Last then
1544          raise Constraint_Error with "Index is out of range";
1545       end if;
1546
1547       if Container.Lock > 0 then
1548          raise Program_Error with
1549            "attempt to tamper with cursors (vector is locked)";
1550       end if;
1551
1552       declare
1553          II : constant Int'Base := Int (Index) - Int (No_Index);
1554          I  : constant Count_Type := Count_Type (II);
1555
1556       begin
1557          Container.Elements (I) := New_Item;
1558       end;
1559    end Replace_Element;
1560
1561    procedure Replace_Element
1562      (Container : in out Vector;
1563       Position  : Cursor;
1564       New_Item  : Element_Type)
1565    is
1566    begin
1567       if not Position.Valid then
1568          raise Constraint_Error with "Position cursor has no element";
1569       end if;
1570
1571       if Position.Index > Container.Last then
1572          raise Constraint_Error with "Position cursor is out of range";
1573       end if;
1574
1575       if Container.Lock > 0 then
1576          raise Program_Error with
1577            "attempt to tamper with cursors (vector is locked)";
1578       end if;
1579
1580       declare
1581          II : constant Int'Base := Int (Position.Index) - Int (No_Index);
1582          I  : constant Count_Type := Count_Type (II);
1583       begin
1584          Container.Elements (I) := New_Item;
1585       end;
1586    end Replace_Element;
1587
1588    ----------------------
1589    -- Reserve_Capacity --
1590    ----------------------
1591
1592    procedure Reserve_Capacity
1593      (Container : in out Vector;
1594       Capacity  : Capacity_Subtype)
1595    is
1596    begin
1597       if Capacity > Container.Capacity then
1598          raise Constraint_Error;  -- ???
1599       end if;
1600    end Reserve_Capacity;
1601
1602    ----------------------
1603    -- Reverse_Elements --
1604    ----------------------
1605
1606    procedure Reverse_Elements (Container : in out Vector) is
1607    begin
1608       if Length (Container) <= 1 then
1609          return;
1610       end if;
1611
1612       if Container.Lock > 0 then
1613          raise Program_Error with
1614            "attempt to tamper with cursors (vector is locked)";
1615       end if;
1616
1617       declare
1618          I, J : Count_Type;
1619          E    : Elements_Array renames Container.Elements;
1620
1621       begin
1622          I := 1;
1623          J := Length (Container);
1624          while I < J loop
1625             declare
1626                EI : constant Element_Type := E (I);
1627             begin
1628                E (I) := E (J);
1629                E (J) := EI;
1630             end;
1631
1632             I := I + 1;
1633             J := J - 1;
1634          end loop;
1635       end;
1636    end Reverse_Elements;
1637
1638    ------------------
1639    -- Reverse_Find --
1640    ------------------
1641
1642    function Reverse_Find
1643      (Container : Vector;
1644       Item      : Element_Type;
1645       Position  : Cursor := No_Element) return Cursor
1646    is
1647       Last : Index_Type'Base;
1648       K    : Count_Type;
1649
1650    begin
1651       if not Position.Valid
1652         or else Position.Index > Last_Index (Container)
1653       then
1654          Last := Last_Index (Container);
1655       else
1656          Last := Position.Index;
1657       end if;
1658
1659       K := Count_Type (Int (Last) - Int (No_Index));
1660       for Indx in reverse Index_Type'First .. Last loop
1661          if Get_Element (Container, K) = Item then
1662             return (True, Indx);
1663          end if;
1664
1665          K := K - 1;
1666       end loop;
1667
1668       return No_Element;
1669    end Reverse_Find;
1670
1671    ------------------------
1672    -- Reverse_Find_Index --
1673    ------------------------
1674
1675    function Reverse_Find_Index
1676      (Container : Vector;
1677       Item      : Element_Type;
1678       Index     : Index_Type := Index_Type'Last) return Extended_Index
1679    is
1680       Last : Index_Type'Base;
1681       K    : Count_Type;
1682
1683    begin
1684       if Index > Last_Index (Container) then
1685          Last := Last_Index (Container);
1686       else
1687          Last := Index;
1688       end if;
1689
1690       K := Count_Type (Int (Last) - Int (No_Index));
1691       for Indx in reverse Index_Type'First .. Last loop
1692          if Get_Element (Container, K) = Item then
1693             return Indx;
1694          end if;
1695
1696          K := K - 1;
1697       end loop;
1698
1699       return No_Index;
1700    end Reverse_Find_Index;
1701
1702    ---------------------
1703    -- Reverse_Iterate --
1704    ---------------------
1705
1706    procedure Reverse_Iterate
1707      (Container : Vector;
1708       Process   : not null access procedure (Container : Vector;
1709                                              Position : Cursor))
1710    is
1711       V : Vector renames Container'Unrestricted_Access.all;
1712       B : Natural renames V.Busy;
1713
1714    begin
1715       B := B + 1;
1716
1717       begin
1718          for Indx in reverse Index_Type'First .. Last_Index (Container) loop
1719             Process (Container, Cursor'(True, Indx));
1720          end loop;
1721       exception
1722          when others =>
1723             B := B - 1;
1724             raise;
1725       end;
1726
1727       B := B - 1;
1728    end Reverse_Iterate;
1729
1730    -----------
1731    -- Right --
1732    -----------
1733
1734    function Right (Container : Vector; Position : Cursor) return Vector is
1735       C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
1736
1737    begin
1738       if Position = No_Element then
1739          Clear (C);
1740          return C;
1741       end if;
1742
1743       if not Has_Element (Container, Position) then
1744          raise Constraint_Error;
1745       end if;
1746
1747       while C.Last /= Container.Last - Position.Index + 1 loop
1748          Delete_First (C);
1749       end loop;
1750
1751       return C;
1752    end Right;
1753
1754    ----------------
1755    -- Set_Length --
1756    ----------------
1757
1758    procedure Set_Length
1759      (Container : in out Vector;
1760       Length    : Capacity_Subtype)
1761    is
1762    begin
1763       if Length = Formal_Vectors.Length (Container) then
1764          return;
1765       end if;
1766
1767       if Container.Busy > 0 then
1768          raise Program_Error with
1769            "attempt to tamper with elements (vector is busy)";
1770       end if;
1771
1772       if Length > Container.Capacity then
1773          raise Constraint_Error;  -- ???
1774       end if;
1775
1776       declare
1777          Last_As_Int : constant Int'Base :=
1778                          Int (Index_Type'First) + Int (Length) - 1;
1779       begin
1780          Container.Last := Index_Type'Base (Last_As_Int);
1781       end;
1782    end Set_Length;
1783
1784    ----------
1785    -- Swap --
1786    ----------
1787
1788    procedure Swap (Container : in out Vector; I, J : Index_Type) is
1789    begin
1790       if I > Container.Last then
1791          raise Constraint_Error with "I index is out of range";
1792       end if;
1793
1794       if J > Container.Last then
1795          raise Constraint_Error with "J index is out of range";
1796       end if;
1797
1798       if I = J then
1799          return;
1800       end if;
1801
1802       if Container.Lock > 0 then
1803          raise Program_Error with
1804            "attempt to tamper with cursors (vector is locked)";
1805       end if;
1806
1807       declare
1808          II : constant Int'Base := Int (I) - Int (No_Index);
1809          JJ : constant Int'Base := Int (J) - Int (No_Index);
1810
1811          EI : Element_Type renames Container.Elements (Count_Type (II));
1812          EJ : Element_Type renames Container.Elements (Count_Type (JJ));
1813
1814          EI_Copy : constant Element_Type := EI;
1815
1816       begin
1817          EI := EJ;
1818          EJ := EI_Copy;
1819       end;
1820    end Swap;
1821
1822    procedure Swap (Container : in out Vector; I, J : Cursor) is
1823    begin
1824       if not I.Valid then
1825          raise Constraint_Error with "I cursor has no element";
1826       end if;
1827
1828       if not J.Valid then
1829          raise Constraint_Error with "J cursor has no element";
1830       end if;
1831
1832       Swap (Container, I.Index, J.Index);
1833    end Swap;
1834
1835    ---------------
1836    -- To_Cursor --
1837    ---------------
1838
1839    function To_Cursor
1840      (Container : Vector;
1841       Index     : Extended_Index) return Cursor
1842    is
1843    begin
1844       if Index not in Index_Type'First .. Last_Index (Container) then
1845          return No_Element;
1846       end if;
1847
1848       return Cursor'(True, Index);
1849    end To_Cursor;
1850
1851    --------------
1852    -- To_Index --
1853    --------------
1854
1855    function To_Index (Position : Cursor) return Extended_Index is
1856    begin
1857       if not Position.Valid then
1858          return No_Index;
1859       end if;
1860
1861       return Position.Index;
1862    end To_Index;
1863
1864    ---------------
1865    -- To_Vector --
1866    ---------------
1867
1868    function To_Vector (Length : Capacity_Subtype) return Vector is
1869    begin
1870       if Length = 0 then
1871          return Empty_Vector;
1872       end if;
1873
1874       declare
1875          First       : constant Int := Int (Index_Type'First);
1876          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
1877          Last        : Index_Type;
1878
1879       begin
1880          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1881             raise Constraint_Error with "Length is out of range";  -- ???
1882          end if;
1883
1884          Last := Index_Type (Last_As_Int);
1885
1886          return (Length, (others => <>), Last => Last,
1887                  others => <>);
1888       end;
1889    end To_Vector;
1890
1891    function To_Vector
1892      (New_Item : Element_Type;
1893       Length   : Capacity_Subtype) return Vector
1894    is
1895    begin
1896       if Length = 0 then
1897          return Empty_Vector;
1898       end if;
1899
1900       declare
1901          First       : constant Int := Int (Index_Type'First);
1902          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
1903          Last        : Index_Type;
1904
1905       begin
1906          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1907             raise Constraint_Error with "Length is out of range";  -- ???
1908          end if;
1909
1910          Last := Index_Type (Last_As_Int);
1911
1912          return (Length, (others => New_Item), Last => Last,
1913                  others => <>);
1914       end;
1915    end To_Vector;
1916
1917    --------------------
1918    -- Update_Element --
1919    --------------------
1920
1921    procedure Update_Element
1922      (Container : in out Vector;
1923       Index     : Index_Type;
1924       Process   : not null access procedure (Element : in out Element_Type))
1925    is
1926       B : Natural renames Container.Busy;
1927       L : Natural renames Container.Lock;
1928
1929    begin
1930       if Index > Container.Last then
1931          raise Constraint_Error with "Index is out of range";
1932       end if;
1933
1934       B := B + 1;
1935       L := L + 1;
1936
1937       declare
1938          II : constant Int'Base := Int (Index) - Int (No_Index);
1939          I  : constant Count_Type := Count_Type (II);
1940
1941       begin
1942          Process (Container.Elements (I));
1943       exception
1944          when others =>
1945             L := L - 1;
1946             B := B - 1;
1947             raise;
1948       end;
1949
1950       L := L - 1;
1951       B := B - 1;
1952    end Update_Element;
1953
1954    procedure Update_Element
1955      (Container : in out Vector;
1956       Position  : Cursor;
1957       Process   : not null access procedure (Element : in out Element_Type))
1958    is
1959    begin
1960       if not Position.Valid then
1961          raise Constraint_Error with "Position cursor has no element";
1962       end if;
1963
1964       Update_Element (Container, Position.Index, Process);
1965    end Update_Element;
1966
1967    -----------
1968    -- Write --
1969    -----------
1970
1971    procedure Write
1972      (Stream    : not null access Root_Stream_Type'Class;
1973       Container : Vector)
1974    is
1975    begin
1976       Count_Type'Base'Write (Stream, Length (Container));
1977
1978       for J in 1 .. Length (Container) loop
1979          Element_Type'Write (Stream, Container.Elements (J));
1980       end loop;
1981    end Write;
1982
1983    procedure Write
1984      (Stream   : not null access Root_Stream_Type'Class;
1985       Position : Cursor)
1986    is
1987    begin
1988       raise Program_Error with "attempt to stream vector cursor";
1989    end Write;
1990
1991 end Ada.Containers.Formal_Vectors;