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