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