gcc/ada/a-convec.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                A D A . C O N T A I N E R S . V E C T O R S               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2006 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- This specification is derived from the Ada Reference Manual for use with --
  12 -- GNAT. The copyright notice above, and the license provisions that follow --
  13 -- apply solely to the  contents of the part following the private keyword. --
  14 --                                                                          --
  15 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  16 -- terms of the  GNU General Public License as published  by the Free Soft- --
  17 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  18 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  19 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  20 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  21 -- for  more details.  You should have  received  a copy of the GNU General --
  22 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  23 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  24 -- Boston, MA 02110-1301, USA.                                              --
  25 --                                                                          --
  26 -- As a special exception,  if other files  instantiate  generics from this --
  27 -- unit, or you link  this unit with other files  to produce an executable, --
  28 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  29 -- covered  by the  GNU  General  Public  License.  This exception does not --
  30 -- however invalidate  any other reasons why  the executable file  might be --
  31 -- covered by the  GNU Public License.                                      --
  32 --                                                                          --
  33 -- This unit was originally developed by Matthew J Heaney.                  --
  34 ------------------------------------------------------------------------------
  35
  36 with Ada.Containers.Generic_Array_Sort;
  37 with Ada.Unchecked_Deallocation;
  38
  39 with System; use type System.Address;
  40
  41 package body Ada.Containers.Vectors is
  42
  43    type Int is range System.Min_Int .. System.Max_Int;
  44    type UInt is mod System.Max_Binary_Modulus;
  45
  46    procedure Free is
  47      new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
  48
  49    ---------
  50    -- "&" --
  51    ---------
  52
  53    function "&" (Left, Right : Vector) return Vector is
  54       LN : constant Count_Type := Length (Left);
  55       RN : constant Count_Type := Length (Right);
  56
  57    begin
  58       if LN = 0 then
  59          if RN = 0 then
  60             return Empty_Vector;
  61          end if;
  62
  63          declare
  64             RE : Elements_Type renames
  65                    Right.Elements (Index_Type'First .. Right.Last);
  66
  67             Elements : constant Elements_Access :=
  68                          new Elements_Type'(RE);
  69
  70          begin
  71             return (Controlled with Elements, Right.Last, 0, 0);
  72          end;
  73       end if;
  74
  75       if RN = 0 then
  76          declare
  77             LE : Elements_Type renames
  78                    Left.Elements (Index_Type'First .. Left.Last);
  79
  80             Elements : constant Elements_Access :=
  81                          new Elements_Type'(LE);
  82
  83          begin
  84             return (Controlled with Elements, Left.Last, 0, 0);
  85          end;
  86
  87       end if;
  88
  89       declare
  90          N           : constant Int'Base := Int (LN) + Int (RN);
  91          Last_As_Int : Int'Base;
  92
  93       begin
  94          if Int (No_Index) > Int'Last - N then
  95             raise Constraint_Error with "new length is out of range";
  96          end if;
  97
  98          Last_As_Int := Int (No_Index) + N;
  99
 100          if Last_As_Int > Int (Index_Type'Last) then
 101             raise Constraint_Error with "new length is out of range";
 102          end if;
 103
 104          declare
 105             Last : constant Index_Type := Index_Type (Last_As_Int);
 106
 107             LE : Elements_Type renames
 108                    Left.Elements (Index_Type'First .. Left.Last);
 109
 110             RE : Elements_Type renames
 111                    Right.Elements (Index_Type'First .. Right.Last);
 112
 113             Elements : constant Elements_Access :=
 114                          new Elements_Type'(LE & RE);
 115
 116          begin
 117             return (Controlled with Elements, Last, 0, 0);
 118          end;
 119       end;
 120    end "&";
 121
 122    function "&" (Left  : Vector; Right : Element_Type) return Vector is
 123       LN : constant Count_Type := Length (Left);
 124
 125    begin
 126       if LN = 0 then
 127          declare
 128             subtype Elements_Subtype is
 129               Elements_Type (Index_Type'First .. Index_Type'First);
 130
 131             Elements : constant Elements_Access :=
 132                          new Elements_Subtype'(others => Right);
 133
 134          begin
 135             return (Controlled with Elements, Index_Type'First, 0, 0);
 136          end;
 137       end if;
 138
 139       declare
 140          Last_As_Int : Int'Base;
 141
 142       begin
 143          if Int (Index_Type'First) > Int'Last - Int (LN) then
 144             raise Constraint_Error with "new length is out of range";
 145          end if;
 146
 147          Last_As_Int := Int (Index_Type'First) + Int (LN);
 148
 149          if Last_As_Int > Int (Index_Type'Last) then
 150             raise Constraint_Error with "new length is out of range";
 151          end if;
 152
 153          declare
 154             Last : constant Index_Type := Index_Type (Last_As_Int);
 155
 156             LE : Elements_Type renames
 157                    Left.Elements (Index_Type'First .. Left.Last);
 158
 159             subtype ET is Elements_Type (Index_Type'First .. Last);
 160
 161             Elements : constant Elements_Access := new ET'(LE & Right);
 162
 163          begin
 164             return (Controlled with Elements, Last, 0, 0);
 165          end;
 166       end;
 167    end "&";
 168
 169    function "&" (Left  : Element_Type; Right : Vector) return Vector is
 170       RN : constant Count_Type := Length (Right);
 171
 172    begin
 173       if RN = 0 then
 174          declare
 175             subtype Elements_Subtype is
 176               Elements_Type (Index_Type'First .. Index_Type'First);
 177
 178             Elements : constant Elements_Access :=
 179                          new Elements_Subtype'(others => Left);
 180
 181          begin
 182             return (Controlled with Elements, Index_Type'First, 0, 0);
 183          end;
 184       end if;
 185
 186       declare
 187          Last_As_Int : Int'Base;
 188
 189       begin
 190          if Int (Index_Type'First) > Int'Last - Int (RN) then
 191             raise Constraint_Error with "new length is out of range";
 192          end if;
 193
 194          Last_As_Int := Int (Index_Type'First) + Int (RN);
 195
 196          if Last_As_Int > Int (Index_Type'Last) then
 197             raise Constraint_Error with "new length is out of range";
 198          end if;
 199
 200          declare
 201             Last : constant Index_Type := Index_Type (Last_As_Int);
 202
 203             RE : Elements_Type renames
 204                    Right.Elements (Index_Type'First .. Right.Last);
 205
 206             subtype ET is Elements_Type (Index_Type'First .. Last);
 207
 208             Elements : constant Elements_Access := new ET'(Left & RE);
 209
 210          begin
 211             return (Controlled with Elements, Last, 0, 0);
 212          end;
 213       end;
 214    end "&";
 215
 216    function "&" (Left, Right : Element_Type) return Vector is
 217    begin
 218       if Index_Type'First >= Index_Type'Last then
 219          raise Constraint_Error with "new length is out of range";
 220       end if;
 221
 222       declare
 223          Last : constant Index_Type := Index_Type'First + 1;
 224
 225          subtype ET is Elements_Type (Index_Type'First .. Last);
 226
 227          Elements : constant Elements_Access := new ET'(Left, Right);
 228
 229       begin
 230          return (Controlled with Elements, Last, 0, 0);
 231       end;
 232    end "&";
 233
 234    ---------
 235    -- "=" --
 236    ---------
 237
 238    function "=" (Left, Right : Vector) return Boolean is
 239    begin
 240       if Left'Address = Right'Address then
 241          return True;
 242       end if;
 243
 244       if Left.Last /= Right.Last then
 245          return False;
 246       end if;
 247
 248       for J in Index_Type range Index_Type'First .. Left.Last loop
 249          if Left.Elements (J) /= Right.Elements (J) then
 250             return False;
 251          end if;
 252       end loop;
 253
 254       return True;
 255    end "=";
 256
 257    ------------
 258    -- Adjust --
 259    ------------
 260
 261    procedure Adjust (Container : in out Vector) is
 262    begin
 263       if Container.Last = No_Index then
 264          Container.Elements := null;
 265          return;
 266       end if;
 267
 268       declare
 269          E : constant Elements_Access := Container.Elements;
 270          L : constant Index_Type := Container.Last;
 271
 272       begin
 273          Container.Elements := null;
 274          Container.Last := No_Index;
 275          Container.Busy := 0;
 276          Container.Lock := 0;
 277          Container.Elements := new Elements_Type'(E (Index_Type'First .. L));
 278          Container.Last := L;
 279       end;
 280    end Adjust;
 281
 282    ------------
 283    -- Append --
 284    ------------
 285
 286    procedure Append (Container : in out Vector; New_Item : Vector) is
 287    begin
 288       if Is_Empty (New_Item) then
 289          return;
 290       end if;
 291
 292       if Container.Last = Index_Type'Last then
 293          raise Constraint_Error with "vector is already at its maximum length";
 294       end if;
 295
 296       Insert
 297         (Container,
 298          Container.Last + 1,
 299          New_Item);
 300    end Append;
 301
 302    procedure Append
 303      (Container : in out Vector;
 304       New_Item  : Element_Type;
 305       Count     : Count_Type := 1)
 306    is
 307    begin
 308       if Count = 0 then
 309          return;
 310       end if;
 311
 312       if Container.Last = Index_Type'Last then
 313          raise Constraint_Error with "vector is already at its maximum length";
 314       end if;
 315
 316       Insert
 317         (Container,
 318          Container.Last + 1,
 319          New_Item,
 320          Count);
 321    end Append;
 322
 323    --------------
 324    -- Capacity --
 325    --------------
 326
 327    function Capacity (Container : Vector) return Count_Type is
 328    begin
 329       if Container.Elements = null then
 330          return 0;
 331       end if;
 332
 333       return Container.Elements'Length;
 334    end Capacity;
 335
 336    -----------
 337    -- Clear --
 338    -----------
 339
 340    procedure Clear (Container : in out Vector) is
 341    begin
 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       Container.Last := No_Index;
 348    end Clear;
 349
 350    --------------
 351    -- Contains --
 352    --------------
 353
 354    function Contains
 355      (Container : Vector;
 356       Item      : Element_Type) return Boolean
 357    is
 358    begin
 359       return Find_Index (Container, Item) /= No_Index;
 360    end Contains;
 361
 362    ------------
 363    -- Delete --
 364    ------------
 365
 366    procedure Delete
 367      (Container : in out Vector;
 368       Index     : Extended_Index;
 369       Count     : Count_Type := 1)
 370    is
 371    begin
 372       if Index < Index_Type'First then
 373          raise Constraint_Error with "Index is out of range (too small)";
 374       end if;
 375
 376       if Index > Container.Last then
 377          if Index > Container.Last + 1 then
 378             raise Constraint_Error with "Index is out of range (too large)";
 379          end if;
 380
 381          return;
 382       end if;
 383
 384       if Count = 0 then
 385          return;
 386       end if;
 387
 388       if Container.Busy > 0 then
 389          raise Program_Error with
 390            "attempt to tamper with elements (vector is busy)";
 391       end if;
 392
 393       declare
 394          I_As_Int        : constant Int := Int (Index);
 395          Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
 396
 397          Count1 : constant Int'Base := Count_Type'Pos (Count);
 398          Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
 399          N      : constant Int'Base := Int'Min (Count1, Count2);
 400
 401          J_As_Int : constant Int'Base := I_As_Int + N;
 402
 403       begin
 404          if J_As_Int > Old_Last_As_Int then
 405             Container.Last := Index - 1;
 406
 407          else
 408             declare
 409                J : constant Index_Type := Index_Type (J_As_Int);
 410                E : Elements_Type renames Container.Elements.all;
 411
 412                New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
 413                New_Last        : constant Index_Type :=
 414                                    Index_Type (New_Last_As_Int);
 415
 416             begin
 417                E (Index .. New_Last) := E (J .. Container.Last);
 418                Container.Last := New_Last;
 419             end;
 420          end if;
 421       end;
 422    end Delete;
 423
 424    procedure Delete
 425      (Container : in out Vector;
 426       Position  : in out Cursor;
 427       Count     : Count_Type := 1)
 428    is
 429    begin
 430       if Position.Container = null then
 431          raise Constraint_Error with "Position cursor has no element";
 432       end if;
 433
 434       if Position.Container /= Container'Unrestricted_Access then
 435          raise Program_Error with "Position cursor denotes wrong container";
 436       end if;
 437
 438       if Position.Index > Container.Last then
 439          raise Program_Error with "Position index is out of range";
 440       end if;
 441
 442       Delete (Container, Position.Index, Count);
 443
 444       --  This is the old behavior, prior to the York API (2005/06):
 445
 446       --  if Position.Index <= Container.Last then
 447       --    Position := (Container'Unchecked_Access, Position.Index);
 448       --  else
 449       --    Position := No_Element;
 450       --  end if;
 451
 452       --  This is the behavior specified by the York API:
 453
 454       Position := No_Element;
 455    end Delete;
 456
 457    ------------------
 458    -- Delete_First --
 459    ------------------
 460
 461    procedure Delete_First
 462      (Container : in out Vector;
 463       Count     : Count_Type := 1)
 464    is
 465    begin
 466       if Count = 0 then
 467          return;
 468       end if;
 469
 470       if Count >= Length (Container) then
 471          Clear (Container);
 472          return;
 473       end if;
 474
 475       Delete (Container, Index_Type'First, Count);
 476    end Delete_First;
 477
 478    -----------------
 479    -- Delete_Last --
 480    -----------------
 481
 482    procedure Delete_Last
 483      (Container : in out Vector;
 484       Count     : Count_Type := 1)
 485    is
 486       Index : Int'Base;
 487
 488    begin
 489       if Count = 0 then
 490          return;
 491       end if;
 492
 493       if Container.Busy > 0 then
 494          raise Program_Error with
 495            "attempt to tamper with elements (vector is busy)";
 496       end if;
 497
 498       Index := Int'Base (Container.Last) - Int'Base (Count);
 499
 500       if Index < Index_Type'Pos (Index_Type'First) then
 501          Container.Last := No_Index;
 502       else
 503          Container.Last := Index_Type (Index);
 504       end if;
 505    end Delete_Last;
 506
 507    -------------
 508    -- Element --
 509    -------------
 510
 511    function Element
 512      (Container : Vector;
 513       Index     : Index_Type) return Element_Type
 514    is
 515    begin
 516       if Index > Container.Last then
 517          raise Constraint_Error with "Index is out of range";
 518       end if;
 519
 520       return Container.Elements (Index);
 521    end Element;
 522
 523    function Element (Position : Cursor) return Element_Type is
 524    begin
 525       if Position.Container = null then
 526          raise Constraint_Error with "Position cursor has no element";
 527       end if;
 528
 529       return Element (Position.Container.all, Position.Index);
 530    end Element;
 531
 532    --------------
 533    -- Finalize --
 534    --------------
 535
 536    procedure Finalize (Container : in out Vector) is
 537       X : Elements_Access := Container.Elements;
 538
 539    begin
 540       if Container.Busy > 0 then
 541          raise Program_Error with
 542            "attempt to tamper with elements (vector is busy)";
 543       end if;
 544
 545       Container.Elements := null;
 546       Container.Last := No_Index;
 547       Free (X);
 548    end Finalize;
 549
 550    ----------
 551    -- Find --
 552    ----------
 553
 554    function Find
 555      (Container : Vector;
 556       Item      : Element_Type;
 557       Position  : Cursor := No_Element) return Cursor
 558    is
 559    begin
 560       if Position.Container /= null then
 561          if Position.Container /= Container'Unrestricted_Access then
 562             raise Program_Error with "Position cursor denotes wrong container";
 563          end if;
 564
 565          if Position.Index > Container.Last then
 566             raise Program_Error with "Position index is out of range";
 567          end if;
 568       end if;
 569
 570       for J in Position.Index .. Container.Last loop
 571          if Container.Elements (J) = Item then
 572             return (Container'Unchecked_Access, J);
 573          end if;
 574       end loop;
 575
 576       return No_Element;
 577    end Find;
 578
 579    ----------------
 580    -- Find_Index --
 581    ----------------
 582
 583    function Find_Index
 584      (Container : Vector;
 585       Item      : Element_Type;
 586       Index     : Index_Type := Index_Type'First) return Extended_Index
 587    is
 588    begin
 589       for Indx in Index .. Container.Last loop
 590          if Container.Elements (Indx) = Item then
 591             return Indx;
 592          end if;
 593       end loop;
 594
 595       return No_Index;
 596    end Find_Index;
 597
 598    -----------
 599    -- First --
 600    -----------
 601
 602    function First (Container : Vector) return Cursor is
 603    begin
 604       if Is_Empty (Container) then
 605          return No_Element;
 606       end if;
 607
 608       return (Container'Unchecked_Access, Index_Type'First);
 609    end First;
 610
 611    -------------------
 612    -- First_Element --
 613    -------------------
 614
 615    function First_Element (Container : Vector) return Element_Type is
 616    begin
 617       return Element (Container, Index_Type'First);
 618    end First_Element;
 619
 620    -----------------
 621    -- First_Index --
 622    -----------------
 623
 624    function First_Index (Container : Vector) return Index_Type is
 625       pragma Unreferenced (Container);
 626    begin
 627       return Index_Type'First;
 628    end First_Index;
 629
 630    ---------------------
 631    -- Generic_Sorting --
 632    ---------------------
 633
 634    package body Generic_Sorting is
 635
 636       ---------------
 637       -- Is_Sorted --
 638       ---------------
 639
 640       function Is_Sorted (Container : Vector) return Boolean is
 641       begin
 642          if Container.Last <= Index_Type'First then
 643             return True;
 644          end if;
 645
 646          declare
 647             E : Elements_Type renames Container.Elements.all;
 648          begin
 649             for I in Index_Type'First .. Container.Last - 1 loop
 650                if E (I + 1) < E (I) then
 651                   return False;
 652                end if;
 653             end loop;
 654          end;
 655
 656          return True;
 657       end Is_Sorted;
 658
 659       -----------
 660       -- Merge --
 661       -----------
 662
 663       procedure Merge (Target, Source : in out Vector) is
 664          I : Index_Type'Base := Target.Last;
 665          J : Index_Type'Base;
 666
 667       begin
 668          if Target.Last < Index_Type'First then
 669             Move (Target => Target, Source => Source);
 670             return;
 671          end if;
 672
 673          if Target'Address = Source'Address then
 674             return;
 675          end if;
 676
 677          if Source.Last < Index_Type'First then
 678             return;
 679          end if;
 680
 681          if Source.Busy > 0 then
 682             raise Program_Error with
 683               "attempt to tamper with elements (vector is busy)";
 684          end if;
 685
 686          Target.Set_Length (Length (Target) + Length (Source));
 687
 688          J := Target.Last;
 689          while Source.Last >= Index_Type'First loop
 690             pragma Assert (Source.Last <= Index_Type'First
 691                              or else not (Source.Elements (Source.Last) <
 692                                           Source.Elements (Source.Last - 1)));
 693
 694             if I < Index_Type'First then
 695                Target.Elements (Index_Type'First .. J) :=
 696                  Source.Elements (Index_Type'First .. Source.Last);
 697
 698                Source.Last := No_Index;
 699                return;
 700             end if;
 701
 702             pragma Assert (I <= Index_Type'First
 703                              or else not (Target.Elements (I) <
 704                                           Target.Elements (I - 1)));
 705
 706             if Source.Elements (Source.Last) < Target.Elements (I) then
 707                Target.Elements (J) := Target.Elements (I);
 708                I := I - 1;
 709
 710             else
 711                Target.Elements (J) := Source.Elements (Source.Last);
 712                Source.Last := Source.Last - 1;
 713             end if;
 714
 715             J := J - 1;
 716          end loop;
 717       end Merge;
 718
 719       ----------
 720       -- Sort --
 721       ----------
 722
 723       procedure Sort (Container : in out Vector)
 724       is
 725          procedure Sort is
 726             new Generic_Array_Sort
 727              (Index_Type   => Index_Type,
 728               Element_Type => Element_Type,
 729               Array_Type   => Elements_Type,
 730               "<"          => "<");
 731
 732       begin
 733          if Container.Last <= Index_Type'First then
 734             return;
 735          end if;
 736
 737          if Container.Lock > 0 then
 738             raise Program_Error with
 739               "attempt to tamper with cursors (vector is locked)";
 740          end if;
 741
 742          Sort (Container.Elements (Index_Type'First .. Container.Last));
 743       end Sort;
 744
 745    end Generic_Sorting;
 746
 747    -----------------
 748    -- Has_Element --
 749    -----------------
 750
 751    function Has_Element (Position : Cursor) return Boolean is
 752    begin
 753       if Position.Container = null then
 754          return False;
 755       end if;
 756
 757       return Position.Index <= Position.Container.Last;
 758    end Has_Element;
 759
 760    ------------
 761    -- Insert --
 762    ------------
 763
 764    procedure Insert
 765      (Container : in out Vector;
 766       Before    : Extended_Index;
 767       New_Item  : Element_Type;
 768       Count     : Count_Type := 1)
 769    is
 770       N : constant Int := Count_Type'Pos (Count);
 771
 772       First           : constant Int := Int (Index_Type'First);
 773       New_Last_As_Int : Int'Base;
 774       New_Last        : Index_Type;
 775       New_Length      : UInt;
 776       Max_Length      : constant UInt := UInt (Count_Type'Last);
 777
 778       Dst : Elements_Access;
 779
 780    begin
 781       if Before < Index_Type'First then
 782          raise Constraint_Error with
 783            "Before index is out of range (too small)";
 784       end if;
 785
 786       if Before > Container.Last
 787         and then Before > Container.Last + 1
 788       then
 789          raise Constraint_Error with
 790            "Before index is out of range (too large)";
 791       end if;
 792
 793       if Count = 0 then
 794          return;
 795       end if;
 796
 797       declare
 798          Old_Last_As_Int : constant Int := Int (Container.Last);
 799
 800       begin
 801          if Old_Last_As_Int > Int'Last - N then
 802
 803             --  ???
 804
 805             --  The purpose of this test is to ensure that the calculation of
 806             --  New_Last_As_Int (see below) doesn't overflow.
 807
 808             --  This isn't quite right, since the only requirements are:
 809             --    V.Last <= Index_Type'Last
 810             --    V.Length <= Count_Type'Last
 811
 812             --  To be strictly correct there's no (explicit) requirement that
 813             --    Old_Last + N <= Int'Last
 814
 815             --  However, there might indeed be an implied requirement, since
 816             --  machine constraints dictate that
 817             --    Index_Type'Last <= Int'Last
 818             --  and so this check is perhaps proper after all.
 819
 820             --  This shouldn't be an issue in practice, since it can only
 821             --  happen when N is very large, or V.Last is near Int'Last.
 822
 823             --  N isn't likely to be large, since there's probably not enough
 824             --  storage.
 825
 826             --  V.Last would only be large if IT'First is very large (and
 827             --  V.Length has some "normal" size).  But typically IT'First is
 828             --  either 0 or 1.
 829
 830             raise Constraint_Error with "new length is out of range";
 831          end if;
 832
 833          New_Last_As_Int := Old_Last_As_Int + N;
 834
 835          if New_Last_As_Int > Int (Index_Type'Last) then
 836             raise Constraint_Error with "new length is out of range";
 837          end if;
 838
 839          New_Length := UInt (New_Last_As_Int - First + Int'(1));
 840
 841          if New_Length > Max_Length then
 842             raise Constraint_Error with "new length is out of range";
 843          end if;
 844
 845          New_Last := Index_Type (New_Last_As_Int);
 846       end;
 847
 848       if Container.Busy > 0 then
 849          raise Program_Error with
 850            "attempt to tamper with elements (vector is busy)";
 851       end if;
 852
 853       if Container.Elements = null then
 854          declare
 855             subtype Elements_Subtype is
 856               Elements_Type (Index_Type'First .. New_Last);
 857          begin
 858             Container.Elements := new Elements_Subtype'(others => New_Item);
 859          end;
 860
 861          Container.Last := New_Last;
 862          return;
 863       end if;
 864
 865       if New_Last <= Container.Elements'Last then
 866          declare
 867             E : Elements_Type renames Container.Elements.all;
 868
 869          begin
 870             if Before <= Container.Last then
 871                declare
 872                   Index_As_Int : constant Int'Base :=
 873                                    Index_Type'Pos (Before) + N;
 874
 875                   Index : constant Index_Type := Index_Type (Index_As_Int);
 876
 877                begin
 878                   E (Index .. New_Last) := E (Before .. Container.Last);
 879
 880                   E (Before .. Index_Type'Pred (Index)) :=
 881                       (others => New_Item);
 882                end;
 883
 884             else
 885                E (Before .. New_Last) := (others => New_Item);
 886             end if;
 887          end;
 888
 889          Container.Last := New_Last;
 890          return;
 891       end if;
 892
 893       declare
 894          C, CC : UInt;
 895
 896       begin
 897          C := UInt'Max (1, Container.Elements'Length);
 898          while C < New_Length loop
 899             if C > UInt'Last / 2 then
 900                C := UInt'Last;
 901                exit;
 902             end if;
 903
 904             C := 2 * C;
 905          end loop;
 906
 907          if C > Max_Length then
 908             C := Max_Length;
 909          end if;
 910
 911          if Index_Type'First <= 0
 912            and then Index_Type'Last >= 0
 913          then
 914             CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1;
 915
 916          else
 917             CC := UInt (Int (Index_Type'Last) - First + 1);
 918          end if;
 919
 920          if C > CC then
 921             C := CC;
 922          end if;
 923
 924          declare
 925             Dst_Last : constant Index_Type :=
 926                          Index_Type (First + UInt'Pos (C) - 1);
 927
 928          begin
 929             Dst := new Elements_Type (Index_Type'First .. Dst_Last);
 930          end;
 931       end;
 932
 933       declare
 934          Src : Elements_Type renames Container.Elements.all;
 935
 936       begin
 937          Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
 938            Src (Index_Type'First .. Index_Type'Pred (Before));
 939
 940          if Before <= Container.Last then
 941             declare
 942                Index_As_Int : constant Int'Base :=
 943                                 Index_Type'Pos (Before) + N;
 944
 945                Index : constant Index_Type := Index_Type (Index_As_Int);
 946
 947             begin
 948                Dst (Before .. Index_Type'Pred (Index)) := (others => New_Item);
 949                Dst (Index .. New_Last) := Src (Before .. Container.Last);
 950             end;
 951
 952          else
 953             Dst (Before .. New_Last) := (others => New_Item);
 954          end if;
 955       exception
 956          when others =>
 957             Free (Dst);
 958             raise;
 959       end;
 960
 961       declare
 962          X : Elements_Access := Container.Elements;
 963       begin
 964          Container.Elements := Dst;
 965          Container.Last := New_Last;
 966          Free (X);
 967       end;
 968    end Insert;
 969
 970    procedure Insert
 971      (Container : in out Vector;
 972       Before    : Extended_Index;
 973       New_Item  : Vector)
 974    is
 975       N : constant Count_Type := Length (New_Item);
 976
 977    begin
 978       if Before < Index_Type'First then
 979          raise Constraint_Error with
 980            "Before index is out of range (too small)";
 981       end if;
 982
 983       if Before > Container.Last
 984         and then Before > Container.Last + 1
 985       then
 986          raise Constraint_Error with
 987            "Before index is out of range (too large)";
 988       end if;
 989
 990       if N = 0 then
 991          return;
 992       end if;
 993
 994       Insert_Space (Container, Before, Count => N);
 995
 996       declare
 997          Dst_Last_As_Int : constant Int'Base :=
 998                              Int'Base (Before) + Int'Base (N) - 1;
 999
1000          Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
1001
1002       begin
1003          if Container'Address /= New_Item'Address then
1004             Container.Elements (Before .. Dst_Last) :=
1005               New_Item.Elements (Index_Type'First .. New_Item.Last);
1006
1007             return;
1008          end if;
1009
1010          declare
1011             subtype Src_Index_Subtype is Index_Type'Base range
1012               Index_Type'First .. Before - 1;
1013
1014             Src : Elements_Type renames
1015                     Container.Elements (Src_Index_Subtype);
1016
1017             Index_As_Int : constant Int'Base :=
1018                              Int (Before) + Src'Length - 1;
1019
1020             Index : constant Index_Type'Base :=
1021                       Index_Type'Base (Index_As_Int);
1022
1023             Dst : Elements_Type renames
1024                     Container.Elements (Before .. Index);
1025
1026          begin
1027             Dst := Src;
1028          end;
1029
1030          if Dst_Last = Container.Last then
1031             return;
1032          end if;
1033
1034          declare
1035             subtype Src_Index_Subtype is Index_Type'Base range
1036               Dst_Last + 1 .. Container.Last;
1037
1038             Src : Elements_Type renames
1039                     Container.Elements (Src_Index_Subtype);
1040
1041             Index_As_Int : constant Int'Base :=
1042                              Dst_Last_As_Int - Src'Length + 1;
1043
1044             Index : constant Index_Type :=
1045                       Index_Type (Index_As_Int);
1046
1047             Dst : Elements_Type renames
1048                     Container.Elements (Index .. Dst_Last);
1049
1050          begin
1051             Dst := Src;
1052          end;
1053       end;
1054    end Insert;
1055
1056    procedure Insert
1057      (Container : in out Vector;
1058       Before    : Cursor;
1059       New_Item  : Vector)
1060    is
1061       Index : Index_Type'Base;
1062
1063    begin
1064       if Before.Container /= null
1065         and then Before.Container /= Container'Unchecked_Access
1066       then
1067          raise Program_Error with "Before cursor denotes wrong container";
1068       end if;
1069
1070       if Is_Empty (New_Item) then
1071          return;
1072       end if;
1073
1074       if Before.Container = null
1075         or else Before.Index > Container.Last
1076       then
1077          if Container.Last = Index_Type'Last then
1078             raise Constraint_Error with
1079               "vector is already at its maximum length";
1080          end if;
1081
1082          Index := Container.Last + 1;
1083
1084       else
1085          Index := Before.Index;
1086       end if;
1087
1088       Insert (Container, Index, New_Item);
1089    end Insert;
1090
1091    procedure Insert
1092      (Container : in out Vector;
1093       Before    : Cursor;
1094       New_Item  : Vector;
1095       Position  : out Cursor)
1096    is
1097       Index : Index_Type'Base;
1098
1099    begin
1100       if Before.Container /= null
1101         and then Before.Container /= Container'Unchecked_Access
1102       then
1103          raise Program_Error with "Before cursor denotes wrong container";
1104       end if;
1105
1106       if Is_Empty (New_Item) then
1107          if Before.Container = null
1108            or else Before.Index > Container.Last
1109          then
1110             Position := No_Element;
1111          else
1112             Position := (Container'Unchecked_Access, Before.Index);
1113          end if;
1114
1115          return;
1116       end if;
1117
1118       if Before.Container = null
1119         or else Before.Index > Container.Last
1120       then
1121          if Container.Last = Index_Type'Last then
1122             raise Constraint_Error with
1123               "vector is already at its maximum length";
1124          end if;
1125
1126          Index := Container.Last + 1;
1127
1128       else
1129          Index := Before.Index;
1130       end if;
1131
1132       Insert (Container, Index, New_Item);
1133
1134       Position := Cursor'(Container'Unchecked_Access, Index);
1135    end Insert;
1136
1137    procedure Insert
1138      (Container : in out Vector;
1139       Before    : Cursor;
1140       New_Item  : Element_Type;
1141       Count     : Count_Type := 1)
1142    is
1143       Index : Index_Type'Base;
1144
1145    begin
1146       if Before.Container /= null
1147         and then Before.Container /= Container'Unchecked_Access
1148       then
1149          raise Program_Error with "Before cursor denotes wrong container";
1150       end if;
1151
1152       if Count = 0 then
1153          return;
1154       end if;
1155
1156       if Before.Container = null
1157         or else Before.Index > Container.Last
1158       then
1159          if Container.Last = Index_Type'Last then
1160             raise Constraint_Error with
1161               "vector is already at its maximum length";
1162          end if;
1163
1164          Index := Container.Last + 1;
1165
1166       else
1167          Index := Before.Index;
1168       end if;
1169
1170       Insert (Container, Index, New_Item, Count);
1171    end Insert;
1172
1173    procedure Insert
1174      (Container : in out Vector;
1175       Before    : Cursor;
1176       New_Item  : Element_Type;
1177       Position  : out Cursor;
1178       Count     : Count_Type := 1)
1179    is
1180       Index : Index_Type'Base;
1181
1182    begin
1183       if Before.Container /= null
1184         and then Before.Container /= Container'Unchecked_Access
1185       then
1186          raise Program_Error with "Before cursor denotes wrong container";
1187       end if;
1188
1189       if Count = 0 then
1190          if Before.Container = null
1191            or else Before.Index > Container.Last
1192          then
1193             Position := No_Element;
1194          else
1195             Position := (Container'Unchecked_Access, Before.Index);
1196          end if;
1197
1198          return;
1199       end if;
1200
1201       if Before.Container = null
1202         or else Before.Index > Container.Last
1203       then
1204          if Container.Last = Index_Type'Last then
1205             raise Constraint_Error with
1206               "vector is already at its maximum length";
1207          end if;
1208
1209          Index := Container.Last + 1;
1210
1211       else
1212          Index := Before.Index;
1213       end if;
1214
1215       Insert (Container, Index, New_Item, Count);
1216
1217       Position := Cursor'(Container'Unchecked_Access, Index);
1218    end Insert;
1219
1220    procedure Insert
1221      (Container : in out Vector;
1222       Before    : Extended_Index;
1223       Count     : Count_Type := 1)
1224    is
1225       New_Item : Element_Type;  -- Default-initialized value
1226       pragma Warnings (Off, New_Item);
1227
1228    begin
1229       Insert (Container, Before, New_Item, Count);
1230    end Insert;
1231
1232    procedure Insert
1233      (Container : in out Vector;
1234       Before    : Cursor;
1235       Position  : out Cursor;
1236       Count     : Count_Type := 1)
1237    is
1238       New_Item : Element_Type;  -- Default-initialized value
1239       pragma Warnings (Off, New_Item);
1240
1241    begin
1242       Insert (Container, Before, New_Item, Position, Count);
1243    end Insert;
1244
1245    ------------------
1246    -- Insert_Space --
1247    ------------------
1248
1249    procedure Insert_Space
1250      (Container : in out Vector;
1251       Before    : Extended_Index;
1252       Count     : Count_Type := 1)
1253    is
1254       N : constant Int := Count_Type'Pos (Count);
1255
1256       First           : constant Int := Int (Index_Type'First);
1257       New_Last_As_Int : Int'Base;
1258       New_Last        : Index_Type;
1259       New_Length      : UInt;
1260       Max_Length      : constant UInt := UInt (Count_Type'Last);
1261
1262       Dst : Elements_Access;
1263
1264    begin
1265       if Before < Index_Type'First then
1266          raise Constraint_Error with
1267            "Before index is out of range (too small)";
1268       end if;
1269
1270       if Before > Container.Last
1271         and then Before > Container.Last + 1
1272       then
1273          raise Constraint_Error with
1274            "Before index is out of range (too large)";
1275       end if;
1276
1277       if Count = 0 then
1278          return;
1279       end if;
1280
1281       declare
1282          Old_Last_As_Int : constant Int := Int (Container.Last);
1283
1284       begin
1285          if Old_Last_As_Int > Int'Last - N then  -- see Insert ???
1286             raise Constraint_Error with "new length is out of range";
1287          end if;
1288
1289          New_Last_As_Int := Old_Last_As_Int + N;
1290
1291          if New_Last_As_Int > Int (Index_Type'Last) then
1292             raise Constraint_Error with "new length is out of range";
1293          end if;
1294
1295          New_Length := UInt (New_Last_As_Int - First + Int'(1));
1296
1297          if New_Length > Max_Length then
1298             raise Constraint_Error with "new length is out of range";
1299          end if;
1300
1301          New_Last := Index_Type (New_Last_As_Int);
1302       end;
1303
1304       if Container.Busy > 0 then
1305          raise Program_Error with
1306            "attempt to tamper with elements (vector is busy)";
1307       end if;
1308
1309       if Container.Elements = null then
1310          Container.Elements :=
1311            new Elements_Type (Index_Type'First .. New_Last);
1312
1313          Container.Last := New_Last;
1314          return;
1315       end if;
1316
1317       if New_Last <= Container.Elements'Last then
1318          declare
1319             E : Elements_Type renames Container.Elements.all;
1320          begin
1321             if Before <= Container.Last then
1322                declare
1323                   Index_As_Int : constant Int'Base :=
1324                                    Index_Type'Pos (Before) + N;
1325
1326                   Index : constant Index_Type := Index_Type (Index_As_Int);
1327
1328                begin
1329                   E (Index .. New_Last) := E (Before .. Container.Last);
1330                end;
1331             end if;
1332          end;
1333
1334          Container.Last := New_Last;
1335          return;
1336       end if;
1337
1338       declare
1339          C, CC : UInt;
1340
1341       begin
1342          C := UInt'Max (1, Container.Elements'Length);
1343          while C < New_Length loop
1344             if C > UInt'Last / 2 then
1345                C := UInt'Last;
1346                exit;
1347             end if;
1348
1349             C := 2 * C;
1350          end loop;
1351
1352          if C > Max_Length then
1353             C := Max_Length;
1354          end if;
1355
1356          if Index_Type'First <= 0
1357            and then Index_Type'Last >= 0
1358          then
1359             CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1;
1360
1361          else
1362             CC := UInt (Int (Index_Type'Last) - First + 1);
1363          end if;
1364
1365          if C > CC then
1366             C := CC;
1367          end if;
1368
1369          declare
1370             Dst_Last : constant Index_Type :=
1371                          Index_Type (First + UInt'Pos (C) - 1);
1372
1373          begin
1374             Dst := new Elements_Type (Index_Type'First .. Dst_Last);
1375          end;
1376       end;
1377
1378       declare
1379          Src : Elements_Type renames Container.Elements.all;
1380
1381       begin
1382          Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
1383            Src (Index_Type'First .. Index_Type'Pred (Before));
1384
1385          if Before <= Container.Last then
1386             declare
1387                Index_As_Int : constant Int'Base :=
1388                                 Index_Type'Pos (Before) + N;
1389
1390                Index : constant Index_Type := Index_Type (Index_As_Int);
1391
1392             begin
1393                Dst (Index .. New_Last) := Src (Before .. Container.Last);
1394             end;
1395          end if;
1396       exception
1397          when others =>
1398             Free (Dst);
1399             raise;
1400       end;
1401
1402       declare
1403          X : Elements_Access := Container.Elements;
1404       begin
1405          Container.Elements := Dst;
1406          Container.Last := New_Last;
1407          Free (X);
1408       end;
1409    end Insert_Space;
1410
1411    procedure Insert_Space
1412      (Container : in out Vector;
1413       Before    : Cursor;
1414       Position  : out Cursor;
1415       Count     : Count_Type := 1)
1416    is
1417       Index : Index_Type'Base;
1418
1419    begin
1420       if Before.Container /= null
1421         and then Before.Container /= Container'Unchecked_Access
1422       then
1423          raise Program_Error with "Before cursor denotes wrong container";
1424       end if;
1425
1426       if Count = 0 then
1427          if Before.Container = null
1428            or else Before.Index > Container.Last
1429          then
1430             Position := No_Element;
1431          else
1432             Position := (Container'Unchecked_Access, Before.Index);
1433          end if;
1434
1435          return;
1436       end if;
1437
1438       if Before.Container = null
1439         or else Before.Index > Container.Last
1440       then
1441          if Container.Last = Index_Type'Last then
1442             raise Constraint_Error with
1443               "vector is already at its maximum length";
1444          end if;
1445
1446          Index := Container.Last + 1;
1447
1448       else
1449          Index := Before.Index;
1450       end if;
1451
1452       Insert_Space (Container, Index, Count => Count);
1453
1454       Position := Cursor'(Container'Unchecked_Access, Index);
1455    end Insert_Space;
1456
1457    --------------
1458    -- Is_Empty --
1459    --------------
1460
1461    function Is_Empty (Container : Vector) return Boolean is
1462    begin
1463       return Container.Last < Index_Type'First;
1464    end Is_Empty;
1465
1466    -------------
1467    -- Iterate --
1468    -------------
1469
1470    procedure Iterate
1471      (Container : Vector;
1472       Process   : not null access procedure (Position : Cursor))
1473    is
1474       V : Vector renames Container'Unrestricted_Access.all;
1475       B : Natural renames V.Busy;
1476
1477    begin
1478       B := B + 1;
1479
1480       begin
1481          for Indx in Index_Type'First .. Container.Last loop
1482             Process (Cursor'(Container'Unchecked_Access, Indx));
1483          end loop;
1484       exception
1485          when others =>
1486             B := B - 1;
1487             raise;
1488       end;
1489
1490       B := B - 1;
1491    end Iterate;
1492
1493    ----------
1494    -- Last --
1495    ----------
1496
1497    function Last (Container : Vector) return Cursor is
1498    begin
1499       if Is_Empty (Container) then
1500          return No_Element;
1501       end if;
1502
1503       return (Container'Unchecked_Access, Container.Last);
1504    end Last;
1505
1506    ------------------
1507    -- Last_Element --
1508    ------------------
1509
1510    function Last_Element (Container : Vector) return Element_Type is
1511    begin
1512       return Element (Container, Container.Last);
1513    end Last_Element;
1514
1515    ----------------
1516    -- Last_Index --
1517    ----------------
1518
1519    function Last_Index (Container : Vector) return Extended_Index is
1520    begin
1521       return Container.Last;
1522    end Last_Index;
1523
1524    ------------
1525    -- Length --
1526    ------------
1527
1528    function Length (Container : Vector) return Count_Type is
1529       L : constant Int := Int (Container.Last);
1530       F : constant Int := Int (Index_Type'First);
1531       N : constant Int'Base := L - F + 1;
1532
1533    begin
1534       return Count_Type (N);
1535    end Length;
1536
1537    ----------
1538    -- Move --
1539    ----------
1540
1541    procedure Move
1542      (Target : in out Vector;
1543       Source : in out Vector)
1544    is
1545    begin
1546       if Target'Address = Source'Address then
1547          return;
1548       end if;
1549
1550       if Target.Busy > 0 then
1551          raise Program_Error with
1552            "attempt to tamper with elements (Target is busy)";
1553       end if;
1554
1555       if Source.Busy > 0 then
1556          raise Program_Error with
1557            "attempt to tamper with elements (Source is busy)";
1558       end if;
1559
1560       declare
1561          Target_Elements : constant Elements_Access := Target.Elements;
1562       begin
1563          Target.Elements := Source.Elements;
1564          Source.Elements := Target_Elements;
1565       end;
1566
1567       Target.Last := Source.Last;
1568       Source.Last := No_Index;
1569    end Move;
1570
1571    ----------
1572    -- Next --
1573    ----------
1574
1575    function Next (Position : Cursor) return Cursor is
1576    begin
1577       if Position.Container = null then
1578          return No_Element;
1579       end if;
1580
1581       if Position.Index < Position.Container.Last then
1582          return (Position.Container, Position.Index + 1);
1583       end if;
1584
1585       return No_Element;
1586    end Next;
1587
1588    ----------
1589    -- Next --
1590    ----------
1591
1592    procedure Next (Position : in out Cursor) is
1593    begin
1594       if Position.Container = null then
1595          return;
1596       end if;
1597
1598       if Position.Index < Position.Container.Last then
1599          Position.Index := Position.Index + 1;
1600       else
1601          Position := No_Element;
1602       end if;
1603    end Next;
1604
1605    -------------
1606    -- Prepend --
1607    -------------
1608
1609    procedure Prepend (Container : in out Vector; New_Item : Vector) is
1610    begin
1611       Insert (Container, Index_Type'First, New_Item);
1612    end Prepend;
1613
1614    procedure Prepend
1615      (Container : in out Vector;
1616       New_Item  : Element_Type;
1617       Count     : Count_Type := 1)
1618    is
1619    begin
1620       Insert (Container,
1621               Index_Type'First,
1622               New_Item,
1623               Count);
1624    end Prepend;
1625
1626    --------------
1627    -- Previous --
1628    --------------
1629
1630    procedure Previous (Position : in out Cursor) is
1631    begin
1632       if Position.Container = null then
1633          return;
1634       end if;
1635
1636       if Position.Index > Index_Type'First then
1637          Position.Index := Position.Index - 1;
1638       else
1639          Position := No_Element;
1640       end if;
1641    end Previous;
1642
1643    function Previous (Position : Cursor) return Cursor is
1644    begin
1645       if Position.Container = null then
1646          return No_Element;
1647       end if;
1648
1649       if Position.Index > Index_Type'First then
1650          return (Position.Container, Position.Index - 1);
1651       end if;
1652
1653       return No_Element;
1654    end Previous;
1655
1656    -------------------
1657    -- Query_Element --
1658    -------------------
1659
1660    procedure Query_Element
1661      (Container : Vector;
1662       Index     : Index_Type;
1663       Process   : not null access procedure (Element : Element_Type))
1664    is
1665       V : Vector renames Container'Unrestricted_Access.all;
1666       B : Natural renames V.Busy;
1667       L : Natural renames V.Lock;
1668
1669    begin
1670       if Index > Container.Last then
1671          raise Constraint_Error with "Index is out of range";
1672       end if;
1673
1674       B := B + 1;
1675       L := L + 1;
1676
1677       begin
1678          Process (V.Elements (Index));
1679       exception
1680          when others =>
1681             L := L - 1;
1682             B := B - 1;
1683             raise;
1684       end;
1685
1686       L := L - 1;
1687       B := B - 1;
1688    end Query_Element;
1689
1690    procedure Query_Element
1691      (Position : Cursor;
1692       Process  : not null access procedure (Element : Element_Type))
1693    is
1694    begin
1695       if Position.Container = null then
1696          raise Constraint_Error with "Position cursor has no element";
1697       end if;
1698
1699       Query_Element (Position.Container.all, Position.Index, Process);
1700    end Query_Element;
1701
1702    ----------
1703    -- Read --
1704    ----------
1705
1706    procedure Read
1707      (Stream    : not null access Root_Stream_Type'Class;
1708       Container : out Vector)
1709    is
1710       Length : Count_Type'Base;
1711       Last   : Index_Type'Base := No_Index;
1712
1713    begin
1714       Clear (Container);
1715
1716       Count_Type'Base'Read (Stream, Length);
1717
1718       if Length > Capacity (Container) then
1719          Reserve_Capacity (Container, Capacity => Length);
1720       end if;
1721
1722       for J in Count_Type range 1 .. Length loop
1723          Last := Last + 1;
1724          Element_Type'Read (Stream, Container.Elements (Last));
1725          Container.Last := Last;
1726       end loop;
1727    end Read;
1728
1729    procedure Read
1730      (Stream   : not null access Root_Stream_Type'Class;
1731       Position : out Cursor)
1732    is
1733    begin
1734       raise Program_Error with "attempt to stream vector cursor";
1735    end Read;
1736
1737    ---------------------
1738    -- Replace_Element --
1739    ---------------------
1740
1741    procedure Replace_Element
1742      (Container : in out Vector;
1743       Index     : Index_Type;
1744       New_Item  : Element_Type)
1745    is
1746    begin
1747       if Index > Container.Last then
1748          raise Constraint_Error with "Index is out of range";
1749       end if;
1750
1751       if Container.Lock > 0 then
1752          raise Program_Error with
1753            "attempt to tamper with cursors (vector is locked)";
1754       end if;
1755
1756       Container.Elements (Index) := New_Item;
1757    end Replace_Element;
1758
1759    procedure Replace_Element
1760      (Container : in out Vector;
1761       Position  : Cursor;
1762       New_Item  : Element_Type)
1763    is
1764    begin
1765       if Position.Container = null then
1766          raise Constraint_Error with "Position cursor has no element";
1767       end if;
1768
1769       if Position.Container /= Container'Unrestricted_Access then
1770          raise Program_Error with "Position cursor denotes wrong container";
1771       end if;
1772
1773       Replace_Element (Container, Position.Index, New_Item);
1774    end Replace_Element;
1775
1776    ----------------------
1777    -- Reserve_Capacity --
1778    ----------------------
1779
1780    procedure Reserve_Capacity
1781      (Container : in out Vector;
1782       Capacity  : Count_Type)
1783    is
1784       N : constant Count_Type := Length (Container);
1785
1786    begin
1787       if Capacity = 0 then
1788          if N = 0 then
1789             declare
1790                X : Elements_Access := Container.Elements;
1791             begin
1792                Container.Elements := null;
1793                Free (X);
1794             end;
1795
1796          elsif N < Container.Elements'Length then
1797             if Container.Busy > 0 then
1798                raise Program_Error with
1799                  "attempt to tamper with elements (vector is busy)";
1800             end if;
1801
1802             declare
1803                subtype Array_Index_Subtype is Index_Type'Base range
1804                  Index_Type'First .. Container.Last;
1805
1806                Src : Elements_Type renames
1807                        Container.Elements (Array_Index_Subtype);
1808
1809                subtype Array_Subtype is
1810                  Elements_Type (Array_Index_Subtype);
1811
1812                X : Elements_Access := Container.Elements;
1813
1814             begin
1815                Container.Elements := new Array_Subtype'(Src);
1816                Free (X);
1817             end;
1818          end if;
1819
1820          return;
1821       end if;
1822
1823       if Container.Elements = null then
1824          declare
1825             Last_As_Int : constant Int'Base :=
1826                             Int (Index_Type'First) + Int (Capacity) - 1;
1827
1828          begin
1829             if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1830                raise Constraint_Error with "new length is out of range";
1831             end if;
1832
1833             declare
1834                Last : constant Index_Type := Index_Type (Last_As_Int);
1835
1836                subtype Array_Subtype is
1837                  Elements_Type (Index_Type'First .. Last);
1838
1839             begin
1840                Container.Elements := new Array_Subtype;
1841             end;
1842          end;
1843
1844          return;
1845       end if;
1846
1847       if Capacity <= N then
1848          if N < Container.Elements'Length then
1849             if Container.Busy > 0 then
1850                raise Program_Error with
1851                  "attempt to tamper with elements (vector is busy)";
1852             end if;
1853
1854             declare
1855                subtype Array_Index_Subtype is Index_Type'Base range
1856                  Index_Type'First .. Container.Last;
1857
1858                Src : Elements_Type renames
1859                        Container.Elements (Array_Index_Subtype);
1860
1861                subtype Array_Subtype is
1862                  Elements_Type (Array_Index_Subtype);
1863
1864                X : Elements_Access := Container.Elements;
1865
1866             begin
1867                Container.Elements := new Array_Subtype'(Src);
1868                Free (X);
1869             end;
1870
1871          end if;
1872
1873          return;
1874       end if;
1875
1876       if Capacity = Container.Elements'Length then
1877          return;
1878       end if;
1879
1880       if Container.Busy > 0 then
1881          raise Program_Error with
1882            "attempt to tamper with elements (vector is busy)";
1883       end if;
1884
1885       declare
1886          Last_As_Int : constant Int'Base :=
1887                          Int (Index_Type'First) + Int (Capacity) - 1;
1888
1889       begin
1890          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1891             raise Constraint_Error with "new length is out of range";
1892          end if;
1893
1894          declare
1895             Last : constant Index_Type := Index_Type (Last_As_Int);
1896
1897             subtype Array_Subtype is
1898               Elements_Type (Index_Type'First .. Last);
1899
1900             E : Elements_Access := new Array_Subtype;
1901
1902          begin
1903             declare
1904                Src : Elements_Type renames
1905                        Container.Elements (Index_Type'First .. Container.Last);
1906
1907                Tgt : Elements_Type renames
1908                        E (Index_Type'First .. Container.Last);
1909
1910             begin
1911                Tgt := Src;
1912
1913             exception
1914                when others =>
1915                   Free (E);
1916                   raise;
1917             end;
1918
1919             declare
1920                X : Elements_Access := Container.Elements;
1921             begin
1922                Container.Elements := E;
1923                Free (X);
1924             end;
1925          end;
1926       end;
1927    end Reserve_Capacity;
1928
1929    ----------------------
1930    -- Reverse_Elements --
1931    ----------------------
1932
1933    procedure Reverse_Elements (Container : in out Vector) is
1934    begin
1935       if Container.Length <= 1 then
1936          return;
1937       end if;
1938
1939       if Container.Lock > 0 then
1940          raise Program_Error with
1941            "attempt to tamper with cursors (vector is locked)";
1942       end if;
1943
1944       declare
1945          I, J : Index_Type;
1946          E    : Elements_Type renames Container.Elements.all;
1947
1948       begin
1949          I := Index_Type'First;
1950          J := Container.Last;
1951          while I < J loop
1952             declare
1953                EI : constant Element_Type := E (I);
1954
1955             begin
1956                E (I) := E (J);
1957                E (J) := EI;
1958             end;
1959
1960             I := I + 1;
1961             J := J - 1;
1962          end loop;
1963       end;
1964    end Reverse_Elements;
1965
1966    ------------------
1967    -- Reverse_Find --
1968    ------------------
1969
1970    function Reverse_Find
1971      (Container : Vector;
1972       Item      : Element_Type;
1973       Position  : Cursor := No_Element) return Cursor
1974    is
1975       Last : Index_Type'Base;
1976
1977    begin
1978       if Position.Container /= null
1979         and then Position.Container /= Container'Unchecked_Access
1980       then
1981          raise Program_Error with "Position cursor denotes wrong container";
1982       end if;
1983
1984       if Position.Container = null
1985         or else Position.Index > Container.Last
1986       then
1987          Last := Container.Last;
1988       else
1989          Last := Position.Index;
1990       end if;
1991
1992       for Indx in reverse Index_Type'First .. Last loop
1993          if Container.Elements (Indx) = Item then
1994             return (Container'Unchecked_Access, Indx);
1995          end if;
1996       end loop;
1997
1998       return No_Element;
1999    end Reverse_Find;
2000
2001    ------------------------
2002    -- Reverse_Find_Index --
2003    ------------------------
2004
2005    function Reverse_Find_Index
2006      (Container : Vector;
2007       Item      : Element_Type;
2008       Index     : Index_Type := Index_Type'Last) return Extended_Index
2009    is
2010       Last : Index_Type'Base;
2011
2012    begin
2013       if Index > Container.Last then
2014          Last := Container.Last;
2015       else
2016          Last := Index;
2017       end if;
2018
2019       for Indx in reverse Index_Type'First .. Last loop
2020          if Container.Elements (Indx) = Item then
2021             return Indx;
2022          end if;
2023       end loop;
2024
2025       return No_Index;
2026    end Reverse_Find_Index;
2027
2028    ---------------------
2029    -- Reverse_Iterate --
2030    ---------------------
2031
2032    procedure Reverse_Iterate
2033      (Container : Vector;
2034       Process   : not null access procedure (Position : Cursor))
2035    is
2036       V : Vector renames Container'Unrestricted_Access.all;
2037       B : Natural renames V.Busy;
2038
2039    begin
2040       B := B + 1;
2041
2042       begin
2043          for Indx in reverse Index_Type'First .. Container.Last loop
2044             Process (Cursor'(Container'Unchecked_Access, Indx));
2045          end loop;
2046       exception
2047          when others =>
2048             B := B - 1;
2049             raise;
2050       end;
2051
2052       B := B - 1;
2053    end Reverse_Iterate;
2054
2055    ----------------
2056    -- Set_Length --
2057    ----------------
2058
2059    procedure Set_Length (Container : in out Vector; Length : Count_Type) is
2060    begin
2061       if Length = Vectors.Length (Container) then
2062          return;
2063       end if;
2064
2065       if Container.Busy > 0 then
2066          raise Program_Error with
2067            "attempt to tamper with elements (vector is busy)";
2068       end if;
2069
2070       if Length > Capacity (Container) then
2071          Reserve_Capacity (Container, Capacity => Length);
2072       end if;
2073
2074       declare
2075          Last_As_Int : constant Int'Base :=
2076                          Int (Index_Type'First) + Int (Length) - 1;
2077       begin
2078          Container.Last := Index_Type'Base (Last_As_Int);
2079       end;
2080    end Set_Length;
2081
2082    ----------
2083    -- Swap --
2084    ----------
2085
2086    procedure Swap (Container : in out Vector; I, J : Index_Type) is
2087    begin
2088       if I > Container.Last then
2089          raise Constraint_Error with "I index is out of range";
2090       end if;
2091
2092       if J > Container.Last then
2093          raise Constraint_Error with "J index is out of range";
2094       end if;
2095
2096       if I = J then
2097          return;
2098       end if;
2099
2100       if Container.Lock > 0 then
2101          raise Program_Error with
2102            "attempt to tamper with cursors (vector is locked)";
2103       end if;
2104
2105       declare
2106          EI : Element_Type renames Container.Elements (I);
2107          EJ : Element_Type renames Container.Elements (J);
2108
2109          EI_Copy : constant Element_Type := EI;
2110
2111       begin
2112          EI := EJ;
2113          EJ := EI_Copy;
2114       end;
2115    end Swap;
2116
2117    procedure Swap (Container : in out Vector; I, J : Cursor) is
2118    begin
2119       if I.Container = null then
2120          raise Constraint_Error with "I cursor has no element";
2121       end if;
2122
2123       if J.Container = null then
2124          raise Constraint_Error with "J cursor has no element";
2125       end if;
2126
2127       if I.Container /= Container'Unrestricted_Access then
2128          raise Program_Error with "I cursor denotes wrong container";
2129       end if;
2130
2131       if J.Container /= Container'Unrestricted_Access then
2132          raise Program_Error with "J cursor denotes wrong container";
2133       end if;
2134
2135       Swap (Container, I.Index, J.Index);
2136    end Swap;
2137
2138    ---------------
2139    -- To_Cursor --
2140    ---------------
2141
2142    function To_Cursor
2143      (Container : Vector;
2144       Index     : Extended_Index) return Cursor
2145    is
2146    begin
2147       if Index not in Index_Type'First .. Container.Last then
2148          return No_Element;
2149       end if;
2150
2151       return Cursor'(Container'Unchecked_Access, Index);
2152    end To_Cursor;
2153
2154    --------------
2155    -- To_Index --
2156    --------------
2157
2158    function To_Index (Position : Cursor) return Extended_Index is
2159    begin
2160       if Position.Container = null then
2161          return No_Index;
2162       end if;
2163
2164       if Position.Index <= Position.Container.Last then
2165          return Position.Index;
2166       end if;
2167
2168       return No_Index;
2169    end To_Index;
2170
2171    ---------------
2172    -- To_Vector --
2173    ---------------
2174
2175    function To_Vector (Length : Count_Type) return Vector is
2176    begin
2177       if Length = 0 then
2178          return Empty_Vector;
2179       end if;
2180
2181       declare
2182          First       : constant Int := Int (Index_Type'First);
2183          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2184          Last        : Index_Type;
2185          Elements    : Elements_Access;
2186
2187       begin
2188          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2189             raise Constraint_Error with "Length is out of range";
2190          end if;
2191
2192          Last := Index_Type (Last_As_Int);
2193          Elements := new Elements_Type (Index_Type'First .. Last);
2194
2195          return Vector'(Controlled with Elements, Last, 0, 0);
2196       end;
2197    end To_Vector;
2198
2199    function To_Vector
2200      (New_Item : Element_Type;
2201       Length   : Count_Type) return Vector
2202    is
2203    begin
2204       if Length = 0 then
2205          return Empty_Vector;
2206       end if;
2207
2208       declare
2209          First       : constant Int := Int (Index_Type'First);
2210          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2211          Last        : Index_Type;
2212          Elements    : Elements_Access;
2213
2214       begin
2215          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2216             raise Constraint_Error with "Length is out of range";
2217          end if;
2218
2219          Last := Index_Type (Last_As_Int);
2220          Elements := new Elements_Type'(Index_Type'First .. Last => New_Item);
2221
2222          return Vector'(Controlled with Elements, Last, 0, 0);
2223       end;
2224    end To_Vector;
2225
2226    --------------------
2227    -- Update_Element --
2228    --------------------
2229
2230    procedure Update_Element
2231      (Container : in out Vector;
2232       Index     : Index_Type;
2233       Process   : not null access procedure (Element : in out Element_Type))
2234    is
2235       B : Natural renames Container.Busy;
2236       L : Natural renames Container.Lock;
2237
2238    begin
2239       if Index > Container.Last then
2240          raise Constraint_Error with "Index is out of range";
2241       end if;
2242
2243       B := B + 1;
2244       L := L + 1;
2245
2246       begin
2247          Process (Container.Elements (Index));
2248       exception
2249          when others =>
2250             L := L - 1;
2251             B := B - 1;
2252             raise;
2253       end;
2254
2255       L := L - 1;
2256       B := B - 1;
2257    end Update_Element;
2258
2259    procedure Update_Element
2260      (Container : in out Vector;
2261       Position  : Cursor;
2262       Process   : not null access procedure (Element : in out Element_Type))
2263    is
2264    begin
2265       if Position.Container = null then
2266          raise Constraint_Error with "Position cursor has no element";
2267       end if;
2268
2269       if Position.Container /= Container'Unrestricted_Access then
2270          raise Program_Error with "Position cursor denotes wrong container";
2271       end if;
2272
2273       Update_Element (Container, Position.Index, Process);
2274    end Update_Element;
2275
2276    -----------
2277    -- Write --
2278    -----------
2279
2280    procedure Write
2281      (Stream    : not null access Root_Stream_Type'Class;
2282       Container : Vector)
2283    is
2284    begin
2285       Count_Type'Base'Write (Stream, Length (Container));
2286
2287       for J in Index_Type'First .. Container.Last loop
2288          Element_Type'Write (Stream, Container.Elements (J));
2289       end loop;
2290    end Write;
2291
2292    procedure Write
2293      (Stream   : not null access Root_Stream_Type'Class;
2294       Position : Cursor)
2295    is
2296    begin
2297       raise Program_Error with "attempt to stream vector cursor";
2298    end Write;
2299
2300 end Ada.Containers.Vectors;