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