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-2009, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with Ada.Containers.Generic_Array_Sort;
  31 with Ada.Unchecked_Deallocation;
  32
  33 with System; use type System.Address;
  34
  35 package body Ada.Containers.Vectors is
  36
  37    type Int is range System.Min_Int .. System.Max_Int;
  38    type UInt is mod System.Max_Binary_Modulus;
  39
  40    procedure Free is
  41      new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
  42
  43    ---------
  44    -- "&" --
  45    ---------
  46
  47    function "&" (Left, Right : Vector) return Vector is
  48       LN : constant Count_Type := Length (Left);
  49       RN : constant Count_Type := Length (Right);
  50
  51    begin
  52       if LN = 0 then
  53          if RN = 0 then
  54             return Empty_Vector;
  55          end if;
  56
  57          declare
  58             RE : Elements_Array renames
  59                    Right.Elements.EA (Index_Type'First .. Right.Last);
  60
  61             Elements : constant Elements_Access :=
  62                          new Elements_Type'(Right.Last, RE);
  63
  64          begin
  65             return (Controlled with Elements, Right.Last, 0, 0);
  66          end;
  67       end if;
  68
  69       if RN = 0 then
  70          declare
  71             LE : Elements_Array renames
  72                    Left.Elements.EA (Index_Type'First .. Left.Last);
  73
  74             Elements : constant Elements_Access :=
  75                          new Elements_Type'(Left.Last, LE);
  76
  77          begin
  78             return (Controlled with Elements, Left.Last, 0, 0);
  79          end;
  80
  81       end if;
  82
  83       declare
  84          N           : constant Int'Base := Int (LN) + Int (RN);
  85          Last_As_Int : Int'Base;
  86
  87       begin
  88          if Int (No_Index) > Int'Last - N then
  89             raise Constraint_Error with "new length is out of range";
  90          end if;
  91
  92          Last_As_Int := Int (No_Index) + N;
  93
  94          if Last_As_Int > Int (Index_Type'Last) then
  95             raise Constraint_Error with "new length is out of range";
  96          end if;
  97
  98          declare
  99             Last : constant Index_Type := Index_Type (Last_As_Int);
 100
 101             LE : Elements_Array renames
 102                    Left.Elements.EA (Index_Type'First .. Left.Last);
 103
 104             RE : Elements_Array renames
 105                    Right.Elements.EA (Index_Type'First .. Right.Last);
 106
 107             Elements : constant Elements_Access :=
 108                          new Elements_Type'(Last, LE & RE);
 109
 110          begin
 111             return (Controlled with Elements, Last, 0, 0);
 112          end;
 113       end;
 114    end "&";
 115
 116    function "&" (Left  : Vector; Right : Element_Type) return Vector is
 117       LN : constant Count_Type := Length (Left);
 118
 119    begin
 120       if LN = 0 then
 121          declare
 122             Elements : constant Elements_Access :=
 123                          new Elements_Type'
 124                                (Last => Index_Type'First,
 125                                 EA   => (others => Right));
 126
 127          begin
 128             return (Controlled with Elements, Index_Type'First, 0, 0);
 129          end;
 130       end if;
 131
 132       declare
 133          Last_As_Int : Int'Base;
 134
 135       begin
 136          if Int (Index_Type'First) > Int'Last - Int (LN) then
 137             raise Constraint_Error with "new length is out of range";
 138          end if;
 139
 140          Last_As_Int := Int (Index_Type'First) + Int (LN);
 141
 142          if Last_As_Int > Int (Index_Type'Last) then
 143             raise Constraint_Error with "new length is out of range";
 144          end if;
 145
 146          declare
 147             Last : constant Index_Type := Index_Type (Last_As_Int);
 148
 149             LE : Elements_Array renames
 150                    Left.Elements.EA (Index_Type'First .. Left.Last);
 151
 152             Elements : constant Elements_Access :=
 153                          new Elements_Type'
 154                                (Last => Last,
 155                                 EA   => LE & Right);
 156
 157          begin
 158             return (Controlled with Elements, Last, 0, 0);
 159          end;
 160       end;
 161    end "&";
 162
 163    function "&" (Left  : Element_Type; Right : Vector) return Vector is
 164       RN : constant Count_Type := Length (Right);
 165
 166    begin
 167       if RN = 0 then
 168          declare
 169             Elements : constant Elements_Access :=
 170                          new Elements_Type'
 171                                (Last => Index_Type'First,
 172                                 EA   => (others => Left));
 173
 174          begin
 175             return (Controlled with Elements, Index_Type'First, 0, 0);
 176          end;
 177       end if;
 178
 179       declare
 180          Last_As_Int : Int'Base;
 181
 182       begin
 183          if Int (Index_Type'First) > Int'Last - Int (RN) then
 184             raise Constraint_Error with "new length is out of range";
 185          end if;
 186
 187          Last_As_Int := Int (Index_Type'First) + Int (RN);
 188
 189          if Last_As_Int > Int (Index_Type'Last) then
 190             raise Constraint_Error with "new length is out of range";
 191          end if;
 192
 193          declare
 194             Last : constant Index_Type := Index_Type (Last_As_Int);
 195
 196             RE : Elements_Array renames
 197                    Right.Elements.EA (Index_Type'First .. Right.Last);
 198
 199             Elements : constant Elements_Access :=
 200                          new Elements_Type'
 201                                (Last => Last,
 202                                 EA   => Left & RE);
 203
 204          begin
 205             return (Controlled with Elements, Last, 0, 0);
 206          end;
 207       end;
 208    end "&";
 209
 210    function "&" (Left, Right : Element_Type) return Vector is
 211    begin
 212       if Index_Type'First >= Index_Type'Last then
 213          raise Constraint_Error with "new length is out of range";
 214       end if;
 215
 216       declare
 217          Last : constant Index_Type := Index_Type'First + 1;
 218
 219          Elements : constant Elements_Access :=
 220                       new Elements_Type'
 221                             (Last => Last,
 222                              EA   => (Left, Right));
 223
 224       begin
 225          return (Controlled with Elements, Last, 0, 0);
 226       end;
 227    end "&";
 228
 229    ---------
 230    -- "=" --
 231    ---------
 232
 233    overriding function "=" (Left, Right : Vector) return Boolean is
 234    begin
 235       if Left'Address = Right'Address then
 236          return True;
 237       end if;
 238
 239       if Left.Last /= Right.Last then
 240          return False;
 241       end if;
 242
 243       for J in Index_Type range Index_Type'First .. Left.Last loop
 244          if Left.Elements.EA (J) /= Right.Elements.EA (J) then
 245             return False;
 246          end if;
 247       end loop;
 248
 249       return True;
 250    end "=";
 251
 252    ------------
 253    -- Adjust --
 254    ------------
 255
 256    procedure Adjust (Container : in out Vector) is
 257    begin
 258       if Container.Last = No_Index then
 259          Container.Elements := null;
 260          return;
 261       end if;
 262
 263       declare
 264          L  : constant Index_Type := Container.Last;
 265          EA : Elements_Array renames
 266                 Container.Elements.EA (Index_Type'First .. L);
 267
 268       begin
 269          Container.Elements := null;
 270          Container.Busy := 0;
 271          Container.Lock := 0;
 272
 273          --  Note: it may seem that the following assignment to Container.Last
 274          --  is useless, since we assign it to L below. However this code is
 275          --  used in case 'new Elements_Type' below raises an exception, to
 276          --  keep Container in a consistent state.
 277
 278          Container.Last := No_Index;
 279          Container.Elements := new Elements_Type'(L, EA);
 280          Container.Last := L;
 281       end;
 282    end Adjust;
 283
 284    ------------
 285    -- Append --
 286    ------------
 287
 288    procedure Append (Container : in out Vector; New_Item : Vector) is
 289    begin
 290       if Is_Empty (New_Item) then
 291          return;
 292       end if;
 293
 294       if Container.Last = Index_Type'Last then
 295          raise Constraint_Error with "vector is already at its maximum length";
 296       end if;
 297
 298       Insert
 299         (Container,
 300          Container.Last + 1,
 301          New_Item);
 302    end Append;
 303
 304    procedure Append
 305      (Container : in out Vector;
 306       New_Item  : Element_Type;
 307       Count     : Count_Type := 1)
 308    is
 309    begin
 310       if Count = 0 then
 311          return;
 312       end if;
 313
 314       if Container.Last = Index_Type'Last then
 315          raise Constraint_Error with "vector is already at its maximum length";
 316       end if;
 317
 318       Insert
 319         (Container,
 320          Container.Last + 1,
 321          New_Item,
 322          Count);
 323    end Append;
 324
 325    --------------
 326    -- Capacity --
 327    --------------
 328
 329    function Capacity (Container : Vector) return Count_Type is
 330    begin
 331       if Container.Elements = null then
 332          return 0;
 333       end if;
 334
 335       return Container.Elements.EA'Length;
 336    end Capacity;
 337
 338    -----------
 339    -- Clear --
 340    -----------
 341
 342    procedure Clear (Container : in out Vector) is
 343    begin
 344       if Container.Busy > 0 then
 345          raise Program_Error with
 346            "attempt to tamper with elements (vector is busy)";
 347       end if;
 348
 349       Container.Last := No_Index;
 350    end Clear;
 351
 352    --------------
 353    -- Contains --
 354    --------------
 355
 356    function Contains
 357      (Container : Vector;
 358       Item      : Element_Type) return Boolean
 359    is
 360    begin
 361       return Find_Index (Container, Item) /= No_Index;
 362    end Contains;
 363
 364    ------------
 365    -- Delete --
 366    ------------
 367
 368    procedure Delete
 369      (Container : in out Vector;
 370       Index     : Extended_Index;
 371       Count     : Count_Type := 1)
 372    is
 373    begin
 374       if Index < Index_Type'First then
 375          raise Constraint_Error with "Index is out of range (too small)";
 376       end if;
 377
 378       if Index > Container.Last then
 379          if Index > Container.Last + 1 then
 380             raise Constraint_Error with "Index is out of range (too large)";
 381          end if;
 382
 383          return;
 384       end if;
 385
 386       if Count = 0 then
 387          return;
 388       end if;
 389
 390       if Container.Busy > 0 then
 391          raise Program_Error with
 392            "attempt to tamper with elements (vector is busy)";
 393       end if;
 394
 395       declare
 396          I_As_Int        : constant Int := Int (Index);
 397          Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
 398
 399          Count1 : constant Int'Base := Count_Type'Pos (Count);
 400          Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
 401          N      : constant Int'Base := Int'Min (Count1, Count2);
 402
 403          J_As_Int : constant Int'Base := I_As_Int + N;
 404
 405       begin
 406          if J_As_Int > Old_Last_As_Int then
 407             Container.Last := Index - 1;
 408
 409          else
 410             declare
 411                J  : constant Index_Type := Index_Type (J_As_Int);
 412                EA : Elements_Array renames Container.Elements.EA;
 413
 414                New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
 415                New_Last        : constant Index_Type :=
 416                                    Index_Type (New_Last_As_Int);
 417
 418             begin
 419                EA (Index .. New_Last) := EA (J .. Container.Last);
 420                Container.Last := New_Last;
 421             end;
 422          end if;
 423       end;
 424    end Delete;
 425
 426    procedure Delete
 427      (Container : in out Vector;
 428       Position  : in out Cursor;
 429       Count     : Count_Type := 1)
 430    is
 431       pragma Warnings (Off, Position);
 432
 433    begin
 434       if Position.Container = null then
 435          raise Constraint_Error with "Position cursor has no element";
 436       end if;
 437
 438       if Position.Container /= Container'Unrestricted_Access then
 439          raise Program_Error with "Position cursor denotes wrong container";
 440       end if;
 441
 442       if Position.Index > Container.Last then
 443          raise Program_Error with "Position index is out of range";
 444       end if;
 445
 446       Delete (Container, Position.Index, Count);
 447       Position := No_Element;
 448    end Delete;
 449
 450    ------------------
 451    -- Delete_First --
 452    ------------------
 453
 454    procedure Delete_First
 455      (Container : in out Vector;
 456       Count     : Count_Type := 1)
 457    is
 458    begin
 459       if Count = 0 then
 460          return;
 461       end if;
 462
 463       if Count >= Length (Container) then
 464          Clear (Container);
 465          return;
 466       end if;
 467
 468       Delete (Container, Index_Type'First, Count);
 469    end Delete_First;
 470
 471    -----------------
 472    -- Delete_Last --
 473    -----------------
 474
 475    procedure Delete_Last
 476      (Container : in out Vector;
 477       Count     : Count_Type := 1)
 478    is
 479       Index : Int'Base;
 480
 481    begin
 482       if Count = 0 then
 483          return;
 484       end if;
 485
 486       if Container.Busy > 0 then
 487          raise Program_Error with
 488            "attempt to tamper with elements (vector is busy)";
 489       end if;
 490
 491       Index := Int'Base (Container.Last) - Int'Base (Count);
 492
 493       Container.Last :=
 494          (if Index < Index_Type'Pos (Index_Type'First)
 495           then No_Index
 496           else Index_Type (Index));
 497    end Delete_Last;
 498
 499    -------------
 500    -- Element --
 501    -------------
 502
 503    function Element
 504      (Container : Vector;
 505       Index     : Index_Type) return Element_Type
 506    is
 507    begin
 508       if Index > Container.Last then
 509          raise Constraint_Error with "Index is out of range";
 510       end if;
 511
 512       return Container.Elements.EA (Index);
 513    end Element;
 514
 515    function Element (Position : Cursor) return Element_Type is
 516    begin
 517       if Position.Container = null then
 518          raise Constraint_Error with "Position cursor has no element";
 519       end if;
 520
 521       if Position.Index > Position.Container.Last then
 522          raise Constraint_Error with "Position cursor is out of range";
 523       end if;
 524
 525       return Position.Container.Elements.EA (Position.Index);
 526    end Element;
 527
 528    --------------
 529    -- Finalize --
 530    --------------
 531
 532    procedure Finalize (Container : in out Vector) is
 533       X : Elements_Access := Container.Elements;
 534
 535    begin
 536       if Container.Busy > 0 then
 537          raise Program_Error with
 538            "attempt to tamper with elements (vector is busy)";
 539       end if;
 540
 541       Container.Elements := null;
 542       Container.Last := No_Index;
 543       Free (X);
 544    end Finalize;
 545
 546    ----------
 547    -- Find --
 548    ----------
 549
 550    function Find
 551      (Container : Vector;
 552       Item      : Element_Type;
 553       Position  : Cursor := No_Element) return Cursor
 554    is
 555    begin
 556       if Position.Container /= null then
 557          if Position.Container /= Container'Unrestricted_Access then
 558             raise Program_Error with "Position cursor denotes wrong container";
 559          end if;
 560
 561          if Position.Index > Container.Last then
 562             raise Program_Error with "Position index is out of range";
 563          end if;
 564       end if;
 565
 566       for J in Position.Index .. Container.Last loop
 567          if Container.Elements.EA (J) = Item then
 568             return (Container'Unchecked_Access, J);
 569          end if;
 570       end loop;
 571
 572       return No_Element;
 573    end Find;
 574
 575    ----------------
 576    -- Find_Index --
 577    ----------------
 578
 579    function Find_Index
 580      (Container : Vector;
 581       Item      : Element_Type;
 582       Index     : Index_Type := Index_Type'First) return Extended_Index
 583    is
 584    begin
 585       for Indx in Index .. Container.Last loop
 586          if Container.Elements.EA (Indx) = Item then
 587             return Indx;
 588          end if;
 589       end loop;
 590
 591       return No_Index;
 592    end Find_Index;
 593
 594    -----------
 595    -- First --
 596    -----------
 597
 598    function First (Container : Vector) return Cursor is
 599    begin
 600       if Is_Empty (Container) then
 601          return No_Element;
 602       end if;
 603
 604       return (Container'Unchecked_Access, Index_Type'First);
 605    end First;
 606
 607    -------------------
 608    -- First_Element --
 609    -------------------
 610
 611    function First_Element (Container : Vector) return Element_Type is
 612    begin
 613       if Container.Last = No_Index then
 614          raise Constraint_Error with "Container is empty";
 615       end if;
 616
 617       return Container.Elements.EA (Index_Type'First);
 618    end First_Element;
 619
 620    -----------------
 621    -- First_Index --
 622    -----------------
 623
 624    function First_Index (Container : Vector) return Index_Type is
 625       pragma Unreferenced (Container);
 626    begin
 627       return Index_Type'First;
 628    end First_Index;
 629
 630    ---------------------
 631    -- Generic_Sorting --
 632    ---------------------
 633
 634    package body Generic_Sorting is
 635
 636       ---------------
 637       -- Is_Sorted --
 638       ---------------
 639
 640       function Is_Sorted (Container : Vector) return Boolean is
 641       begin
 642          if Container.Last <= Index_Type'First then
 643             return True;
 644          end if;
 645
 646          declare
 647             EA : Elements_Array renames Container.Elements.EA;
 648          begin
 649             for I in Index_Type'First .. Container.Last - 1 loop
 650                if EA (I + 1) < EA (I) then
 651                   return False;
 652                end if;
 653             end loop;
 654          end;
 655
 656          return True;
 657       end Is_Sorted;
 658
 659       -----------
 660       -- Merge --
 661       -----------
 662
 663       procedure Merge (Target, Source : in out Vector) is
 664          I : Index_Type'Base := Target.Last;
 665          J : Index_Type'Base;
 666
 667       begin
 668          if Target.Last < Index_Type'First then
 669             Move (Target => Target, Source => Source);
 670             return;
 671          end if;
 672
 673          if Target'Address = Source'Address then
 674             return;
 675          end if;
 676
 677          if Source.Last < Index_Type'First then
 678             return;
 679          end if;
 680
 681          if Source.Busy > 0 then
 682             raise Program_Error with
 683               "attempt to tamper with elements (vector is busy)";
 684          end if;
 685
 686          Target.Set_Length (Length (Target) + Length (Source));
 687
 688          declare
 689             TA : Elements_Array renames Target.Elements.EA;
 690             SA : Elements_Array renames Source.Elements.EA;
 691
 692          begin
 693             J := Target.Last;
 694             while Source.Last >= Index_Type'First loop
 695                pragma Assert (Source.Last <= Index_Type'First
 696                                 or else not (SA (Source.Last) <
 697                                              SA (Source.Last - 1)));
 698
 699                if I < Index_Type'First then
 700                   TA (Index_Type'First .. J) :=
 701                     SA (Index_Type'First .. Source.Last);
 702
 703                   Source.Last := No_Index;
 704                   return;
 705                end if;
 706
 707                pragma Assert (I <= Index_Type'First
 708                                 or else not (TA (I) < TA (I - 1)));
 709
 710                if SA (Source.Last) < TA (I) then
 711                   TA (J) := TA (I);
 712                   I := I - 1;
 713
 714                else
 715                   TA (J) := SA (Source.Last);
 716                   Source.Last := Source.Last - 1;
 717                end if;
 718
 719                J := J - 1;
 720             end loop;
 721          end;
 722       end Merge;
 723
 724       ----------
 725       -- Sort --
 726       ----------
 727
 728       procedure Sort (Container : in out Vector)
 729       is
 730          procedure Sort is
 731             new Generic_Array_Sort
 732              (Index_Type   => Index_Type,
 733               Element_Type => Element_Type,
 734               Array_Type   => Elements_Array,
 735               "<"          => "<");
 736
 737       begin
 738          if Container.Last <= Index_Type'First then
 739             return;
 740          end if;
 741
 742          if Container.Lock > 0 then
 743             raise Program_Error with
 744               "attempt to tamper with cursors (vector is locked)";
 745          end if;
 746
 747          Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
 748       end Sort;
 749
 750    end Generic_Sorting;
 751
 752    -----------------
 753    -- Has_Element --
 754    -----------------
 755
 756    function Has_Element (Position : Cursor) return Boolean is
 757    begin
 758       if Position.Container = null then
 759          return False;
 760       end if;
 761
 762       return Position.Index <= Position.Container.Last;
 763    end Has_Element;
 764
 765    ------------
 766    -- Insert --
 767    ------------
 768
 769    procedure Insert
 770      (Container : in out Vector;
 771       Before    : Extended_Index;
 772       New_Item  : Element_Type;
 773       Count     : Count_Type := 1)
 774    is
 775       N : constant Int := Count_Type'Pos (Count);
 776
 777       First           : constant Int := Int (Index_Type'First);
 778       New_Last_As_Int : Int'Base;
 779       New_Last        : Index_Type;
 780       New_Length      : UInt;
 781       Max_Length      : constant UInt := UInt (Count_Type'Last);
 782
 783       Dst : Elements_Access;
 784
 785    begin
 786       if Before < Index_Type'First then
 787          raise Constraint_Error with
 788            "Before index is out of range (too small)";
 789       end if;
 790
 791       if Before > Container.Last
 792         and then Before > Container.Last + 1
 793       then
 794          raise Constraint_Error with
 795            "Before index is out of range (too large)";
 796       end if;
 797
 798       if Count = 0 then
 799          return;
 800       end if;
 801
 802       declare
 803          Old_Last_As_Int : constant Int := Int (Container.Last);
 804
 805       begin
 806          if Old_Last_As_Int > Int'Last - N then
 807             raise Constraint_Error with "new length is out of range";
 808          end if;
 809
 810          New_Last_As_Int := Old_Last_As_Int + N;
 811
 812          if New_Last_As_Int > Int (Index_Type'Last) then
 813             raise Constraint_Error with "new length is out of range";
 814          end if;
 815
 816          New_Length := UInt (New_Last_As_Int - First + Int'(1));
 817
 818          if New_Length > Max_Length then
 819             raise Constraint_Error with "new length is out of range";
 820          end if;
 821
 822          New_Last := Index_Type (New_Last_As_Int);
 823       end;
 824
 825       if Container.Busy > 0 then
 826          raise Program_Error with
 827            "attempt to tamper with elements (vector is busy)";
 828       end if;
 829
 830       if Container.Elements = null then
 831          Container.Elements := new Elements_Type'
 832                                      (Last => New_Last,
 833                                       EA   => (others => New_Item));
 834          Container.Last := New_Last;
 835          return;
 836       end if;
 837
 838       if New_Last <= Container.Elements.Last then
 839          declare
 840             EA : Elements_Array renames Container.Elements.EA;
 841
 842          begin
 843             if Before <= Container.Last then
 844                declare
 845                   Index_As_Int : constant Int'Base :=
 846                                    Index_Type'Pos (Before) + N;
 847
 848                   Index : constant Index_Type := Index_Type (Index_As_Int);
 849
 850                begin
 851                   EA (Index .. New_Last) := EA (Before .. Container.Last);
 852
 853                   EA (Before .. Index_Type'Pred (Index)) :=
 854                       (others => New_Item);
 855                end;
 856
 857             else
 858                EA (Before .. New_Last) := (others => New_Item);
 859             end if;
 860          end;
 861
 862          Container.Last := New_Last;
 863          return;
 864       end if;
 865
 866       declare
 867          C, CC : UInt;
 868
 869       begin
 870          C := UInt'Max (1, Container.Elements.EA'Length);  -- ???
 871          while C < New_Length loop
 872             if C > UInt'Last / 2 then
 873                C := UInt'Last;
 874                exit;
 875             end if;
 876
 877             C := 2 * C;
 878          end loop;
 879
 880          if C > Max_Length then
 881             C := Max_Length;
 882          end if;
 883
 884          if Index_Type'First <= 0
 885            and then Index_Type'Last >= 0
 886          then
 887             CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1;
 888          else
 889             CC := UInt (Int (Index_Type'Last) - First + 1);
 890          end if;
 891
 892          if C > CC then
 893             C := CC;
 894          end if;
 895
 896          declare
 897             Dst_Last : constant Index_Type :=
 898                          Index_Type (First + UInt'Pos (C) - 1);
 899
 900          begin
 901             Dst := new Elements_Type (Dst_Last);
 902          end;
 903       end;
 904
 905       declare
 906          SA : Elements_Array renames Container.Elements.EA;
 907          DA : Elements_Array renames Dst.EA;
 908
 909       begin
 910          DA (Index_Type'First .. Index_Type'Pred (Before)) :=
 911            SA (Index_Type'First .. Index_Type'Pred (Before));
 912
 913          if Before <= Container.Last then
 914             declare
 915                Index_As_Int : constant Int'Base :=
 916                                 Index_Type'Pos (Before) + N;
 917
 918                Index : constant Index_Type := Index_Type (Index_As_Int);
 919
 920             begin
 921                DA (Before .. Index_Type'Pred (Index)) := (others => New_Item);
 922                DA (Index .. New_Last) := SA (Before .. Container.Last);
 923             end;
 924
 925          else
 926             DA (Before .. New_Last) := (others => New_Item);
 927          end if;
 928       exception
 929          when others =>
 930             Free (Dst);
 931             raise;
 932       end;
 933
 934       declare
 935          X : Elements_Access := Container.Elements;
 936       begin
 937          Container.Elements := Dst;
 938          Container.Last := New_Last;
 939          Free (X);
 940       end;
 941    end Insert;
 942
 943    procedure Insert
 944      (Container : in out Vector;
 945       Before    : Extended_Index;
 946       New_Item  : Vector)
 947    is
 948       N : constant Count_Type := Length (New_Item);
 949
 950    begin
 951       if Before < Index_Type'First then
 952          raise Constraint_Error with
 953            "Before index is out of range (too small)";
 954       end if;
 955
 956       if Before > Container.Last
 957         and then Before > Container.Last + 1
 958       then
 959          raise Constraint_Error with
 960            "Before index is out of range (too large)";
 961       end if;
 962
 963       if N = 0 then
 964          return;
 965       end if;
 966
 967       Insert_Space (Container, Before, Count => N);
 968
 969       declare
 970          Dst_Last_As_Int : constant Int'Base :=
 971                              Int'Base (Before) + Int'Base (N) - 1;
 972
 973          Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
 974
 975       begin
 976          if Container'Address /= New_Item'Address then
 977             Container.Elements.EA (Before .. Dst_Last) :=
 978               New_Item.Elements.EA (Index_Type'First .. New_Item.Last);
 979
 980             return;
 981          end if;
 982
 983          declare
 984             subtype Src_Index_Subtype is Index_Type'Base range
 985               Index_Type'First .. Before - 1;
 986
 987             Src : Elements_Array renames
 988                     Container.Elements.EA (Src_Index_Subtype);
 989
 990             Index_As_Int : constant Int'Base :=
 991                              Int (Before) + Src'Length - 1;
 992
 993             Index : constant Index_Type'Base :=
 994                       Index_Type'Base (Index_As_Int);
 995
 996             Dst : Elements_Array renames
 997                     Container.Elements.EA (Before .. Index);
 998
 999          begin
1000             Dst := Src;
1001          end;
1002
1003          if Dst_Last = Container.Last then
1004             return;
1005          end if;
1006
1007          declare
1008             subtype Src_Index_Subtype is Index_Type'Base range
1009               Dst_Last + 1 .. Container.Last;
1010
1011             Src : Elements_Array renames
1012                     Container.Elements.EA (Src_Index_Subtype);
1013
1014             Index_As_Int : constant Int'Base :=
1015                              Dst_Last_As_Int - Src'Length + 1;
1016
1017             Index : constant Index_Type :=
1018                       Index_Type (Index_As_Int);
1019
1020             Dst : Elements_Array renames
1021                     Container.Elements.EA (Index .. Dst_Last);
1022
1023          begin
1024             Dst := Src;
1025          end;
1026       end;
1027    end Insert;
1028
1029    procedure Insert
1030      (Container : in out Vector;
1031       Before    : Cursor;
1032       New_Item  : Vector)
1033    is
1034       Index : Index_Type'Base;
1035
1036    begin
1037       if Before.Container /= null
1038         and then Before.Container /= Container'Unchecked_Access
1039       then
1040          raise Program_Error with "Before cursor denotes wrong container";
1041       end if;
1042
1043       if Is_Empty (New_Item) then
1044          return;
1045       end if;
1046
1047       if Before.Container = null
1048         or else Before.Index > Container.Last
1049       then
1050          if Container.Last = Index_Type'Last then
1051             raise Constraint_Error with
1052               "vector is already at its maximum length";
1053          end if;
1054
1055          Index := Container.Last + 1;
1056
1057       else
1058          Index := Before.Index;
1059       end if;
1060
1061       Insert (Container, Index, New_Item);
1062    end Insert;
1063
1064    procedure Insert
1065      (Container : in out Vector;
1066       Before    : Cursor;
1067       New_Item  : Vector;
1068       Position  : out Cursor)
1069    is
1070       Index : Index_Type'Base;
1071
1072    begin
1073       if Before.Container /= null
1074         and then Before.Container /= Container'Unchecked_Access
1075       then
1076          raise Program_Error with "Before cursor denotes wrong container";
1077       end if;
1078
1079       if Is_Empty (New_Item) then
1080          if Before.Container = null
1081            or else Before.Index > Container.Last
1082          then
1083             Position := No_Element;
1084          else
1085             Position := (Container'Unchecked_Access, Before.Index);
1086          end if;
1087
1088          return;
1089       end if;
1090
1091       if Before.Container = null
1092         or else Before.Index > Container.Last
1093       then
1094          if Container.Last = Index_Type'Last then
1095             raise Constraint_Error with
1096               "vector is already at its maximum length";
1097          end if;
1098
1099          Index := Container.Last + 1;
1100
1101       else
1102          Index := Before.Index;
1103       end if;
1104
1105       Insert (Container, Index, New_Item);
1106
1107       Position := Cursor'(Container'Unchecked_Access, Index);
1108    end Insert;
1109
1110    procedure Insert
1111      (Container : in out Vector;
1112       Before    : Cursor;
1113       New_Item  : Element_Type;
1114       Count     : Count_Type := 1)
1115    is
1116       Index : Index_Type'Base;
1117
1118    begin
1119       if Before.Container /= null
1120         and then Before.Container /= Container'Unchecked_Access
1121       then
1122          raise Program_Error with "Before cursor denotes wrong container";
1123       end if;
1124
1125       if Count = 0 then
1126          return;
1127       end if;
1128
1129       if Before.Container = null
1130         or else Before.Index > Container.Last
1131       then
1132          if Container.Last = Index_Type'Last then
1133             raise Constraint_Error with
1134               "vector is already at its maximum length";
1135          end if;
1136
1137          Index := Container.Last + 1;
1138
1139       else
1140          Index := Before.Index;
1141       end if;
1142
1143       Insert (Container, Index, New_Item, Count);
1144    end Insert;
1145
1146    procedure Insert
1147      (Container : in out Vector;
1148       Before    : Cursor;
1149       New_Item  : Element_Type;
1150       Position  : out Cursor;
1151       Count     : Count_Type := 1)
1152    is
1153       Index : Index_Type'Base;
1154
1155    begin
1156       if Before.Container /= null
1157         and then Before.Container /= Container'Unchecked_Access
1158       then
1159          raise Program_Error with "Before cursor denotes wrong container";
1160       end if;
1161
1162       if Count = 0 then
1163          if Before.Container = null
1164            or else Before.Index > Container.Last
1165          then
1166             Position := No_Element;
1167          else
1168             Position := (Container'Unchecked_Access, Before.Index);
1169          end if;
1170
1171          return;
1172       end if;
1173
1174       if Before.Container = null
1175         or else Before.Index > Container.Last
1176       then
1177          if Container.Last = Index_Type'Last then
1178             raise Constraint_Error with
1179               "vector is already at its maximum length";
1180          end if;
1181
1182          Index := Container.Last + 1;
1183
1184       else
1185          Index := Before.Index;
1186       end if;
1187
1188       Insert (Container, Index, New_Item, Count);
1189
1190       Position := Cursor'(Container'Unchecked_Access, Index);
1191    end Insert;
1192
1193    procedure Insert
1194      (Container : in out Vector;
1195       Before    : Extended_Index;
1196       Count     : Count_Type := 1)
1197    is
1198       New_Item : Element_Type;  -- Default-initialized value
1199       pragma Warnings (Off, New_Item);
1200
1201    begin
1202       Insert (Container, Before, New_Item, Count);
1203    end Insert;
1204
1205    procedure Insert
1206      (Container : in out Vector;
1207       Before    : Cursor;
1208       Position  : out Cursor;
1209       Count     : Count_Type := 1)
1210    is
1211       New_Item : Element_Type;  -- Default-initialized value
1212       pragma Warnings (Off, New_Item);
1213
1214    begin
1215       Insert (Container, Before, New_Item, Position, Count);
1216    end Insert;
1217
1218    ------------------
1219    -- Insert_Space --
1220    ------------------
1221
1222    procedure Insert_Space
1223      (Container : in out Vector;
1224       Before    : Extended_Index;
1225       Count     : Count_Type := 1)
1226    is
1227       N : constant Int := Count_Type'Pos (Count);
1228
1229       First           : constant Int := Int (Index_Type'First);
1230       New_Last_As_Int : Int'Base;
1231       New_Last        : Index_Type;
1232       New_Length      : UInt;
1233       Max_Length      : constant UInt := UInt (Count_Type'Last);
1234
1235       Dst : Elements_Access;
1236
1237    begin
1238       if Before < Index_Type'First then
1239          raise Constraint_Error with
1240            "Before index is out of range (too small)";
1241       end if;
1242
1243       if Before > Container.Last
1244         and then Before > Container.Last + 1
1245       then
1246          raise Constraint_Error with
1247            "Before index is out of range (too large)";
1248       end if;
1249
1250       if Count = 0 then
1251          return;
1252       end if;
1253
1254       declare
1255          Old_Last_As_Int : constant Int := Int (Container.Last);
1256
1257       begin
1258          if Old_Last_As_Int > Int'Last - N then
1259             raise Constraint_Error with "new length is out of range";
1260          end if;
1261
1262          New_Last_As_Int := Old_Last_As_Int + N;
1263
1264          if New_Last_As_Int > Int (Index_Type'Last) then
1265             raise Constraint_Error with "new length is out of range";
1266          end if;
1267
1268          New_Length := UInt (New_Last_As_Int - First + Int'(1));
1269
1270          if New_Length > Max_Length then
1271             raise Constraint_Error with "new length is out of range";
1272          end if;
1273
1274          New_Last := Index_Type (New_Last_As_Int);
1275       end;
1276
1277       if Container.Busy > 0 then
1278          raise Program_Error with
1279            "attempt to tamper with elements (vector is busy)";
1280       end if;
1281
1282       if Container.Elements = null then
1283          Container.Elements := new Elements_Type (New_Last);
1284          Container.Last := New_Last;
1285          return;
1286       end if;
1287
1288       if New_Last <= Container.Elements.Last then
1289          declare
1290             EA : Elements_Array renames Container.Elements.EA;
1291          begin
1292             if Before <= Container.Last then
1293                declare
1294                   Index_As_Int : constant Int'Base :=
1295                                    Index_Type'Pos (Before) + N;
1296
1297                   Index : constant Index_Type := Index_Type (Index_As_Int);
1298
1299                begin
1300                   EA (Index .. New_Last) := EA (Before .. Container.Last);
1301                end;
1302             end if;
1303          end;
1304
1305          Container.Last := New_Last;
1306          return;
1307       end if;
1308
1309       declare
1310          C, CC : UInt;
1311
1312       begin
1313          C := UInt'Max (1, Container.Elements.EA'Length);  -- ???
1314          while C < New_Length loop
1315             if C > UInt'Last / 2 then
1316                C := UInt'Last;
1317                exit;
1318             end if;
1319
1320             C := 2 * C;
1321          end loop;
1322
1323          if C > Max_Length then
1324             C := Max_Length;
1325          end if;
1326
1327          if Index_Type'First <= 0
1328            and then Index_Type'Last >= 0
1329          then
1330             CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1;
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       Last :=
1959         (if Position.Container = null or else Position.Index > Container.Last
1960          then Container.Last
1961          else Position.Index);
1962
1963       for Indx in reverse Index_Type'First .. Last loop
1964          if Container.Elements.EA (Indx) = Item then
1965             return (Container'Unchecked_Access, Indx);
1966          end if;
1967       end loop;
1968
1969       return No_Element;
1970    end Reverse_Find;
1971
1972    ------------------------
1973    -- Reverse_Find_Index --
1974    ------------------------
1975
1976    function Reverse_Find_Index
1977      (Container : Vector;
1978       Item      : Element_Type;
1979       Index     : Index_Type := Index_Type'Last) return Extended_Index
1980    is
1981       Last : constant Index_Type'Base :=
1982                Index_Type'Min (Container.Last, Index);
1983
1984    begin
1985       for Indx in reverse Index_Type'First .. Last loop
1986          if Container.Elements.EA (Indx) = Item then
1987             return Indx;
1988          end if;
1989       end loop;
1990
1991       return No_Index;
1992    end Reverse_Find_Index;
1993
1994    ---------------------
1995    -- Reverse_Iterate --
1996    ---------------------
1997
1998    procedure Reverse_Iterate
1999      (Container : Vector;
2000       Process   : not null access procedure (Position : Cursor))
2001    is
2002       V : Vector renames Container'Unrestricted_Access.all;
2003       B : Natural renames V.Busy;
2004
2005    begin
2006       B := B + 1;
2007
2008       begin
2009          for Indx in reverse Index_Type'First .. Container.Last loop
2010             Process (Cursor'(Container'Unchecked_Access, Indx));
2011          end loop;
2012       exception
2013          when others =>
2014             B := B - 1;
2015             raise;
2016       end;
2017
2018       B := B - 1;
2019    end Reverse_Iterate;
2020
2021    ----------------
2022    -- Set_Length --
2023    ----------------
2024
2025    procedure Set_Length (Container : in out Vector; Length : Count_Type) is
2026    begin
2027       if Length = Vectors.Length (Container) then
2028          return;
2029       end if;
2030
2031       if Container.Busy > 0 then
2032          raise Program_Error with
2033            "attempt to tamper with elements (vector is busy)";
2034       end if;
2035
2036       if Length > Capacity (Container) then
2037          Reserve_Capacity (Container, Capacity => Length);
2038       end if;
2039
2040       declare
2041          Last_As_Int : constant Int'Base :=
2042                          Int (Index_Type'First) + Int (Length) - 1;
2043       begin
2044          Container.Last := Index_Type'Base (Last_As_Int);
2045       end;
2046    end Set_Length;
2047
2048    ----------
2049    -- Swap --
2050    ----------
2051
2052    procedure Swap (Container : in out Vector; I, J : Index_Type) is
2053    begin
2054       if I > Container.Last then
2055          raise Constraint_Error with "I index is out of range";
2056       end if;
2057
2058       if J > Container.Last then
2059          raise Constraint_Error with "J index is out of range";
2060       end if;
2061
2062       if I = J then
2063          return;
2064       end if;
2065
2066       if Container.Lock > 0 then
2067          raise Program_Error with
2068            "attempt to tamper with cursors (vector is locked)";
2069       end if;
2070
2071       declare
2072          EI_Copy : constant Element_Type := Container.Elements.EA (I);
2073       begin
2074          Container.Elements.EA (I) := Container.Elements.EA (J);
2075          Container.Elements.EA (J) := EI_Copy;
2076       end;
2077    end Swap;
2078
2079    procedure Swap (Container : in out Vector; I, J : Cursor) is
2080    begin
2081       if I.Container = null then
2082          raise Constraint_Error with "I cursor has no element";
2083       end if;
2084
2085       if J.Container = null then
2086          raise Constraint_Error with "J cursor has no element";
2087       end if;
2088
2089       if I.Container /= Container'Unrestricted_Access then
2090          raise Program_Error with "I cursor denotes wrong container";
2091       end if;
2092
2093       if J.Container /= Container'Unrestricted_Access then
2094          raise Program_Error with "J cursor denotes wrong container";
2095       end if;
2096
2097       Swap (Container, I.Index, J.Index);
2098    end Swap;
2099
2100    ---------------
2101    -- To_Cursor --
2102    ---------------
2103
2104    function To_Cursor
2105      (Container : Vector;
2106       Index     : Extended_Index) return Cursor
2107    is
2108    begin
2109       if Index not in Index_Type'First .. Container.Last then
2110          return No_Element;
2111       end if;
2112
2113       return Cursor'(Container'Unchecked_Access, Index);
2114    end To_Cursor;
2115
2116    --------------
2117    -- To_Index --
2118    --------------
2119
2120    function To_Index (Position : Cursor) return Extended_Index is
2121    begin
2122       if Position.Container = null then
2123          return No_Index;
2124       end if;
2125
2126       if Position.Index <= Position.Container.Last then
2127          return Position.Index;
2128       end if;
2129
2130       return No_Index;
2131    end To_Index;
2132
2133    ---------------
2134    -- To_Vector --
2135    ---------------
2136
2137    function To_Vector (Length : Count_Type) return Vector is
2138    begin
2139       if Length = 0 then
2140          return Empty_Vector;
2141       end if;
2142
2143       declare
2144          First       : constant Int := Int (Index_Type'First);
2145          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2146          Last        : Index_Type;
2147          Elements    : Elements_Access;
2148
2149       begin
2150          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2151             raise Constraint_Error with "Length is out of range";
2152          end if;
2153
2154          Last := Index_Type (Last_As_Int);
2155          Elements := new Elements_Type (Last);
2156
2157          return Vector'(Controlled with Elements, Last, 0, 0);
2158       end;
2159    end To_Vector;
2160
2161    function To_Vector
2162      (New_Item : Element_Type;
2163       Length   : Count_Type) return Vector
2164    is
2165    begin
2166       if Length = 0 then
2167          return Empty_Vector;
2168       end if;
2169
2170       declare
2171          First       : constant Int := Int (Index_Type'First);
2172          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2173          Last        : Index_Type;
2174          Elements    : Elements_Access;
2175
2176       begin
2177          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2178             raise Constraint_Error with "Length is out of range";
2179          end if;
2180
2181          Last := Index_Type (Last_As_Int);
2182          Elements := new Elements_Type'(Last, EA => (others => New_Item));
2183
2184          return Vector'(Controlled with Elements, Last, 0, 0);
2185       end;
2186    end To_Vector;
2187
2188    --------------------
2189    -- Update_Element --
2190    --------------------
2191
2192    procedure Update_Element
2193      (Container : in out Vector;
2194       Index     : Index_Type;
2195       Process   : not null access procedure (Element : in out Element_Type))
2196    is
2197       B : Natural renames Container.Busy;
2198       L : Natural renames Container.Lock;
2199
2200    begin
2201       if Index > Container.Last then
2202          raise Constraint_Error with "Index is out of range";
2203       end if;
2204
2205       B := B + 1;
2206       L := L + 1;
2207
2208       begin
2209          Process (Container.Elements.EA (Index));
2210       exception
2211          when others =>
2212             L := L - 1;
2213             B := B - 1;
2214             raise;
2215       end;
2216
2217       L := L - 1;
2218       B := B - 1;
2219    end Update_Element;
2220
2221    procedure Update_Element
2222      (Container : in out Vector;
2223       Position  : Cursor;
2224       Process   : not null access procedure (Element : in out Element_Type))
2225    is
2226    begin
2227       if Position.Container = null then
2228          raise Constraint_Error with "Position cursor has no element";
2229       end if;
2230
2231       if Position.Container /= Container'Unrestricted_Access then
2232          raise Program_Error with "Position cursor denotes wrong container";
2233       end if;
2234
2235       Update_Element (Container, Position.Index, Process);
2236    end Update_Element;
2237
2238    -----------
2239    -- Write --
2240    -----------
2241
2242    procedure Write
2243      (Stream    : not null access Root_Stream_Type'Class;
2244       Container : Vector)
2245    is
2246    begin
2247       Count_Type'Base'Write (Stream, Length (Container));
2248
2249       for J in Index_Type'First .. Container.Last loop
2250          Element_Type'Write (Stream, Container.Elements.EA (J));
2251       end loop;
2252    end Write;
2253
2254    procedure Write
2255      (Stream   : not null access Root_Stream_Type'Class;
2256       Position : Cursor)
2257    is
2258    begin
2259       raise Program_Error with "attempt to stream vector cursor";
2260    end Write;
2261
2262 end Ada.Containers.Vectors;