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