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