gcc/ada/a-convec.adb

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