gcc/ada/a-convec.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                          ADA.CONTAINERS.VECTORS                          --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2004 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,  59 Temple Place - Suite 330,  Boston, --
  24 -- MA 02111-1307, 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);
  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);
  84          end;
  85
  86       end if;
  87
  88       declare
  89          Last_As_Int : constant Int'Base :=
  90                          Int (Index_Type'First) + Int (LN) + Int (RN) - 1;
  91
  92          Last : constant Index_Type := Index_Type (Last_As_Int);
  93
  94          LE : Elements_Type renames
  95                 Left.Elements (Index_Type'First .. Left.Last);
  96
  97          RE : Elements_Type renames
  98                 Right.Elements (Index_Type'First .. Right.Last);
  99
 100          Elements : constant Elements_Access :=
 101                          new Elements_Type'(LE & RE);
 102
 103       begin
 104          return (Controlled with Elements, Last);
 105       end;
 106    end "&";
 107
 108    function "&" (Left  : Vector; Right : Element_Type) return Vector is
 109       LN : constant Count_Type := Length (Left);
 110
 111    begin
 112       if LN = 0 then
 113          declare
 114             subtype Elements_Subtype is
 115               Elements_Type (Index_Type'First .. Index_Type'First);
 116
 117             Elements : constant Elements_Access :=
 118                          new Elements_Subtype'(others => Right);
 119
 120          begin
 121             return (Controlled with Elements, Index_Type'First);
 122          end;
 123       end if;
 124
 125       declare
 126          Last_As_Int : constant Int'Base :=
 127                          Int (Index_Type'First) + Int (LN);
 128
 129          Last : constant Index_Type := Index_Type (Last_As_Int);
 130
 131          LE : Elements_Type renames
 132                 Left.Elements (Index_Type'First .. Left.Last);
 133
 134          subtype ET is Elements_Type (Index_Type'First .. Last);
 135
 136          Elements : constant Elements_Access := new ET'(LE & Right);
 137
 138       begin
 139          return (Controlled with Elements, Last);
 140       end;
 141    end "&";
 142
 143    function "&" (Left  : Element_Type; Right : Vector) return Vector is
 144       RN : constant Count_Type := Length (Right);
 145
 146    begin
 147       if RN = 0 then
 148          declare
 149             subtype Elements_Subtype is
 150               Elements_Type (Index_Type'First .. Index_Type'First);
 151
 152             Elements : constant Elements_Access :=
 153                          new Elements_Subtype'(others => Left);
 154
 155          begin
 156             return (Controlled with Elements, Index_Type'First);
 157          end;
 158       end if;
 159
 160       declare
 161          Last_As_Int : constant Int'Base :=
 162                          Int (Index_Type'First) + Int (RN);
 163
 164          Last : constant Index_Type := Index_Type (Last_As_Int);
 165
 166          RE : Elements_Type renames
 167                 Right.Elements (Index_Type'First .. Right.Last);
 168
 169          subtype ET is Elements_Type (Index_Type'First .. Last);
 170
 171          Elements : constant Elements_Access := new ET'(Left & RE);
 172
 173       begin
 174          return (Controlled with Elements, Last);
 175       end;
 176    end "&";
 177
 178    function "&" (Left, Right  : Element_Type) return Vector is
 179       subtype IT is Index_Type'Base range
 180         Index_Type'First .. Index_Type'Succ (Index_Type'First);
 181
 182       subtype ET is Elements_Type (IT);
 183
 184       Elements : constant Elements_Access := new ET'(Left, Right);
 185
 186    begin
 187       return Vector'(Controlled with Elements, Elements'Last);
 188    end "&";
 189
 190    ---------
 191    -- "=" --
 192    ---------
 193
 194    function "=" (Left, Right : Vector) return Boolean is
 195    begin
 196       if Left'Address = Right'Address then
 197          return True;
 198       end if;
 199
 200       if Left.Last /= Right.Last then
 201          return False;
 202       end if;
 203
 204       for J in Index_Type range Index_Type'First .. Left.Last loop
 205          if Left.Elements (J) /= Right.Elements (J) then
 206             return False;
 207          end if;
 208       end loop;
 209
 210       return True;
 211    end "=";
 212
 213    ------------
 214    -- Adjust --
 215    ------------
 216
 217    procedure Adjust (Container : in out Vector) is
 218    begin
 219       if Container.Elements = null then
 220          return;
 221       end if;
 222
 223       if Container.Elements'Length = 0
 224         or else Container.Last < Index_Type'First
 225       then
 226          Container.Elements := null;
 227          return;
 228       end if;
 229
 230       declare
 231          X : constant Elements_Access := Container.Elements;
 232          L : constant Index_Type'Base := Container.Last;
 233          E : Elements_Type renames X (Index_Type'First .. L);
 234       begin
 235          Container.Elements := null;
 236          Container.Last := Index_Type'Pred (Index_Type'First);
 237          Container.Elements := new Elements_Type'(E);
 238          Container.Last := L;
 239       end;
 240    end Adjust;
 241
 242    ------------
 243    -- Append --
 244    ------------
 245
 246    procedure Append (Container : in out Vector; New_Item : Vector) is
 247    begin
 248       if Is_Empty (New_Item) then
 249          return;
 250       end if;
 251
 252       Insert
 253         (Container,
 254          Index_Type'Succ (Container.Last),
 255          New_Item);
 256    end Append;
 257
 258    procedure Append
 259      (Container : in out Vector;
 260       New_Item  : Element_Type;
 261       Count     : Count_Type := 1)
 262    is
 263    begin
 264       if Count = 0 then
 265          return;
 266       end if;
 267
 268       Insert
 269         (Container,
 270          Index_Type'Succ (Container.Last),
 271          New_Item,
 272          Count);
 273    end Append;
 274
 275    ------------
 276    -- Assign --
 277    ------------
 278
 279    procedure Assign
 280      (Target : in out Vector;
 281       Source : Vector)
 282    is
 283       N : constant Count_Type := Length (Source);
 284
 285    begin
 286       if Target'Address = Source'Address then
 287          return;
 288       end if;
 289
 290       Clear (Target);
 291
 292       if N = 0 then
 293          return;
 294       end if;
 295
 296       if N > Capacity (Target) then
 297          Reserve_Capacity (Target, Capacity => N);
 298       end if;
 299
 300       Target.Elements (Index_Type'First .. Source.Last) :=
 301         Source.Elements (Index_Type'First .. Source.Last);
 302
 303       Target.Last := Source.Last;
 304    end Assign;
 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       Container.Last := Index_Type'Pred (Index_Type'First);
 326    end Clear;
 327
 328    --------------
 329    -- Contains --
 330    --------------
 331
 332    function Contains
 333      (Container : Vector;
 334       Item      : Element_Type) return Boolean
 335    is
 336    begin
 337       return Find_Index (Container, Item) /= No_Index;
 338    end Contains;
 339
 340    ------------
 341    -- Delete --
 342    ------------
 343
 344    procedure Delete
 345      (Container : in out Vector;
 346       Index     : Extended_Index;
 347       Count     : Count_Type := 1)
 348    is
 349    begin
 350       if Count = 0 then
 351          return;
 352       end if;
 353
 354       declare
 355          subtype I_Subtype is Index_Type'Base range
 356            Index_Type'First .. Container.Last;
 357
 358          I : constant I_Subtype := Index;
 359          --  TODO: not sure whether to relax this check ???
 360
 361          I_As_Int : constant Int := Int (I);
 362
 363          Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
 364
 365          Count1 : constant Int'Base := Count_Type'Pos (Count);
 366          Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
 367
 368          N : constant Int'Base := Int'Min (Count1, Count2);
 369
 370          J_As_Int : constant Int'Base := I_As_Int + N;
 371          J        : constant Index_Type'Base := Index_Type'Base (J_As_Int);
 372
 373          E : Elements_Type renames Container.Elements.all;
 374
 375          New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
 376
 377          New_Last : constant Extended_Index :=
 378                       Extended_Index (New_Last_As_Int);
 379
 380       begin
 381          E (I .. New_Last) := E (J .. Container.Last);
 382          Container.Last := New_Last;
 383       end;
 384    end Delete;
 385
 386    procedure Delete
 387      (Container : in out Vector;
 388       Position  : in out Cursor;
 389       Count     : Count_Type := 1)
 390    is
 391    begin
 392
 393       if Position.Container /= null
 394         and then Position.Container /=
 395                    Vector_Access'(Container'Unchecked_Access)
 396       then
 397          raise Program_Error;
 398       end if;
 399
 400       if Position.Container = null
 401         or else Position.Index > Container.Last
 402       then
 403          Position := No_Element;
 404          return;
 405       end if;
 406
 407       Delete (Container, Position.Index, Count);
 408
 409       if Position.Index <= Container.Last then
 410          Position := (Container'Unchecked_Access, Position.Index);
 411       else
 412          Position := No_Element;
 413       end if;
 414    end Delete;
 415
 416    ------------------
 417    -- Delete_First --
 418    ------------------
 419
 420    procedure Delete_First
 421      (Container : in out Vector;
 422       Count     : Count_Type := 1)
 423    is
 424    begin
 425       if Count = 0 then
 426          return;
 427       end if;
 428
 429       if Count >= Length (Container) then
 430          Clear (Container);
 431          return;
 432       end if;
 433
 434       Delete (Container, Index_Type'First, Count);
 435    end Delete_First;
 436
 437    -----------------
 438    -- Delete_Last --
 439    -----------------
 440
 441    procedure Delete_Last
 442      (Container : in out Vector;
 443       Count     : Count_Type := 1)
 444    is
 445       Index : Int'Base;
 446
 447    begin
 448       if Count = 0 then
 449          return;
 450       end if;
 451
 452       if Count >= Length (Container) then
 453          Clear (Container);
 454          return;
 455       end if;
 456
 457       Index := Int'Base (Container.Last) - Int'Base (Count) + 1;
 458
 459       Delete (Container, Index_Type'Base (Index), Count);
 460    end Delete_Last;
 461
 462    -------------
 463    -- Element --
 464    -------------
 465
 466    function Element
 467      (Container : Vector;
 468       Index     : Index_Type) return Element_Type
 469    is
 470       subtype T is Index_Type'Base range
 471         Index_Type'First .. Container.Last;
 472    begin
 473       return Container.Elements (T'(Index));
 474    end Element;
 475
 476    function Element (Position : Cursor) return Element_Type is
 477    begin
 478       return Element (Position.Container.all, Position.Index);
 479    end Element;
 480
 481    --------------
 482    -- Finalize --
 483    --------------
 484
 485    procedure Finalize (Container : in out Vector) is
 486       X : Elements_Access := Container.Elements;
 487    begin
 488       Container.Elements := null;
 489       Container.Last := Index_Type'Pred (Index_Type'First);
 490       Free (X);
 491    end Finalize;
 492
 493    ----------
 494    -- Find --
 495    ----------
 496
 497    function Find
 498      (Container : Vector;
 499       Item      : Element_Type;
 500       Position  : Cursor := No_Element) return Cursor is
 501
 502    begin
 503       if Position.Container /= null
 504         and then Position.Container /=
 505                    Vector_Access'(Container'Unchecked_Access)
 506       then
 507          raise Program_Error;
 508       end if;
 509
 510       for J in Position.Index .. Container.Last loop
 511          if Container.Elements (J) = Item then
 512             return (Container'Unchecked_Access, J);
 513          end if;
 514       end loop;
 515
 516       return No_Element;
 517    end Find;
 518
 519    ----------------
 520    -- Find_Index --
 521    ----------------
 522
 523    function Find_Index
 524      (Container : Vector;
 525       Item      : Element_Type;
 526       Index     : Index_Type := Index_Type'First) return Extended_Index is
 527    begin
 528       for Indx in Index .. Container.Last loop
 529          if Container.Elements (Indx) = Item then
 530             return Indx;
 531          end if;
 532       end loop;
 533
 534       return No_Index;
 535    end Find_Index;
 536
 537    -----------
 538    -- First --
 539    -----------
 540
 541    function First (Container : Vector) return Cursor is
 542    begin
 543       if Is_Empty (Container) then
 544          return No_Element;
 545       end if;
 546
 547       return (Container'Unchecked_Access, Index_Type'First);
 548    end First;
 549
 550    -------------------
 551    -- First_Element --
 552    -------------------
 553
 554    function First_Element (Container : Vector) return Element_Type is
 555    begin
 556       return Element (Container, Index_Type'First);
 557    end First_Element;
 558
 559    -----------------
 560    -- First_Index --
 561    -----------------
 562
 563    function First_Index (Container : Vector) return Index_Type is
 564       pragma Unreferenced (Container);
 565    begin
 566       return Index_Type'First;
 567    end First_Index;
 568
 569    ------------------
 570    -- Generic_Sort --
 571    ------------------
 572
 573    procedure Generic_Sort (Container : Vector)
 574    is
 575       procedure Sort is
 576          new Generic_Array_Sort
 577           (Index_Type   => Index_Type,
 578            Element_Type => Element_Type,
 579            Array_Type   => Elements_Type,
 580            "<"          => "<");
 581
 582    begin
 583       if Container.Elements = null then
 584          return;
 585       end if;
 586
 587       Sort (Container.Elements (Index_Type'First .. Container.Last));
 588    end Generic_Sort;
 589
 590    -----------------
 591    -- Has_Element --
 592    -----------------
 593
 594    function Has_Element (Position : Cursor) return Boolean is
 595    begin
 596       if Position.Container = null then
 597          return False;
 598       end if;
 599
 600       return Position.Index <= Position.Container.Last;
 601    end Has_Element;
 602
 603    ------------
 604    -- Insert --
 605    ------------
 606
 607    procedure Insert
 608      (Container : in out Vector;
 609       Before    : Extended_Index;
 610       New_Item  : Element_Type;
 611       Count     : Count_Type := 1)
 612    is
 613       Old_Last : constant Extended_Index := Container.Last;
 614
 615       Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last);
 616
 617       N : constant Int := Count_Type'Pos (Count);
 618
 619       New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N;
 620
 621       New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int);
 622
 623       Index : Index_Type;
 624
 625       Dst_Last : Index_Type;
 626       Dst      : Elements_Access;
 627
 628    begin
 629       if Count = 0 then
 630          return;
 631       end if;
 632
 633       declare
 634          subtype Before_Subtype is Index_Type'Base range
 635            Index_Type'First .. Index_Type'Succ (Container.Last);
 636
 637          Old_First : constant Before_Subtype := Before;
 638
 639          Old_First_As_Int : constant Int := Index_Type'Pos (Old_First);
 640
 641          New_First_As_Int : constant Int'Base := Old_First_As_Int + N;
 642
 643       begin
 644          Index := Index_Type (New_First_As_Int);
 645       end;
 646
 647       if Container.Elements = null then
 648          declare
 649             subtype Elements_Subtype is
 650               Elements_Type (Index_Type'First .. New_Last);
 651          begin
 652             Container.Elements := new Elements_Subtype'(others => New_Item);
 653          end;
 654
 655          Container.Last := New_Last;
 656          return;
 657       end if;
 658
 659       if New_Last <= Container.Elements'Last then
 660          declare
 661             E : Elements_Type renames Container.Elements.all;
 662          begin
 663             E (Index .. New_Last) := E (Before .. Container.Last);
 664             E (Before .. Index_Type'Pred (Index)) := (others => New_Item);
 665          end;
 666
 667          Container.Last := New_Last;
 668          return;
 669       end if;
 670
 671       declare
 672          First : constant Int := Int (Index_Type'First);
 673
 674          New_Size : constant Int'Base := New_Last_As_Int - First + 1;
 675          Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1;
 676
 677          Size, Dst_Last_As_Int : Int'Base;
 678
 679       begin
 680          if New_Size >= Max_Size / 2 then
 681             Dst_Last := Index_Type'Last;
 682
 683          else
 684             Size := Container.Elements'Length;
 685
 686             if Size = 0 then
 687                Size := 1;
 688             end if;
 689
 690             while Size < New_Size loop
 691                Size := 2 * Size;
 692             end loop;
 693
 694             Dst_Last_As_Int := First + Size - 1;
 695             Dst_Last := Index_Type (Dst_Last_As_Int);
 696          end if;
 697       end;
 698
 699       Dst := new Elements_Type (Index_Type'First .. Dst_Last);
 700
 701       declare
 702          Src : Elements_Type renames Container.Elements.all;
 703
 704       begin
 705          Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
 706            Src (Index_Type'First .. Index_Type'Pred (Before));
 707
 708          Dst (Before .. Index_Type'Pred (Index)) :=
 709            (others => New_Item);
 710
 711          Dst (Index .. New_Last) :=
 712            Src (Before .. Container.Last);
 713
 714       exception
 715          when others =>
 716             Free (Dst);
 717             raise;
 718       end;
 719
 720       declare
 721          X : Elements_Access := Container.Elements;
 722       begin
 723          Container.Elements := Dst;
 724          Container.Last := New_Last;
 725          Free (X);
 726       end;
 727    end Insert;
 728
 729    procedure Insert
 730      (Container : in out Vector;
 731       Before    : Extended_Index;
 732       New_Item  : Vector)
 733    is
 734       N : constant Count_Type := Length (New_Item);
 735
 736    begin
 737       if N = 0 then
 738          return;
 739       end if;
 740
 741       Insert_Space (Container, Before, Count => N);
 742
 743       declare
 744          Dst_Last_As_Int : constant Int'Base :=
 745                              Int'Base (Before) + Int'Base (N) - 1;
 746
 747          Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
 748
 749       begin
 750          if Container'Address = New_Item'Address then
 751             declare
 752                subtype Src_Index_Subtype is Index_Type'Base range
 753                  Index_Type'First .. Index_Type'Pred (Before);
 754
 755                Src : Elements_Type renames
 756                        Container.Elements (Src_Index_Subtype);
 757
 758                Index_As_Int : constant Int'Base :=
 759                                 Int (Before) + Src'Length - 1;
 760
 761                Index : constant Index_Type'Base :=
 762                          Index_Type'Base (Index_As_Int);
 763
 764                Dst : Elements_Type renames
 765                        Container.Elements (Before .. Index);
 766
 767             begin
 768                Dst := Src;
 769             end;
 770
 771             declare
 772                subtype Src_Index_Subtype is Index_Type'Base range
 773                  Index_Type'Succ (Dst_Last) .. Container.Last;
 774
 775                Src : Elements_Type renames
 776                        Container.Elements (Src_Index_Subtype);
 777
 778                Index_As_Int : constant Int'Base :=
 779                                 Dst_Last_As_Int - Src'Length + 1;
 780
 781                Index : constant Index_Type'Base :=
 782                          Index_Type'Base (Index_As_Int);
 783
 784                Dst : Elements_Type renames
 785                        Container.Elements (Index .. Dst_Last);
 786
 787             begin
 788                Dst := Src;
 789             end;
 790
 791          else
 792             Container.Elements (Before .. Dst_Last) :=
 793               New_Item.Elements (Index_Type'First .. New_Item.Last);
 794          end if;
 795       end;
 796    end Insert;
 797
 798    procedure Insert
 799      (Container : in out Vector;
 800       Before    : Cursor;
 801       New_Item  : Vector)
 802    is
 803       Index : Index_Type'Base;
 804
 805    begin
 806       if Before.Container /= null
 807         and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
 808       then
 809          raise Program_Error;
 810       end if;
 811
 812       if Is_Empty (New_Item) then
 813          return;
 814       end if;
 815
 816       if Before.Container = null
 817         or else Before.Index > Container.Last
 818       then
 819          Index := Index_Type'Succ (Container.Last);
 820       else
 821          Index := Before.Index;
 822       end if;
 823
 824       Insert (Container, Index, New_Item);
 825    end Insert;
 826
 827    procedure Insert
 828      (Container : in out Vector;
 829       Before    : Cursor;
 830       New_Item  : Vector;
 831       Position  : out Cursor)
 832    is
 833       Index : Index_Type'Base;
 834
 835    begin
 836       if Before.Container /= null
 837         and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
 838       then
 839          raise Program_Error;
 840       end if;
 841
 842       if Is_Empty (New_Item) then
 843          if Before.Container = null
 844            or else Before.Index > Container.Last
 845          then
 846             Position := No_Element;
 847          else
 848             Position := (Container'Unchecked_Access, Before.Index);
 849          end if;
 850
 851          return;
 852       end if;
 853
 854       if Before.Container = null
 855         or else Before.Index > Container.Last
 856       then
 857          Index := Index_Type'Succ (Container.Last);
 858       else
 859          Index := Before.Index;
 860       end if;
 861
 862       Insert (Container, Index, New_Item);
 863
 864       Position := Cursor'(Container'Unchecked_Access, Index);
 865    end Insert;
 866
 867    procedure Insert
 868      (Container : in out Vector;
 869       Before    : Cursor;
 870       New_Item  : Element_Type;
 871       Count     : Count_Type := 1)
 872    is
 873       Index : Index_Type'Base;
 874
 875    begin
 876       if Before.Container /= null
 877         and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
 878       then
 879          raise Program_Error;
 880       end if;
 881
 882       if Count = 0 then
 883          return;
 884       end if;
 885
 886       if Before.Container = null
 887         or else Before.Index > Container.Last
 888       then
 889          Index := Index_Type'Succ (Container.Last);
 890       else
 891          Index := Before.Index;
 892       end if;
 893
 894       Insert (Container, Index, New_Item, Count);
 895    end Insert;
 896
 897    procedure Insert
 898      (Container : in out Vector;
 899       Before    : Cursor;
 900       New_Item  : Element_Type;
 901       Position  : out Cursor;
 902       Count     : Count_Type := 1)
 903    is
 904       Index : Index_Type'Base;
 905
 906    begin
 907       if Before.Container /= null
 908         and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
 909       then
 910          raise Program_Error;
 911       end if;
 912
 913       if Count = 0 then
 914          if Before.Container = null
 915            or else Before.Index > Container.Last
 916          then
 917             Position := No_Element;
 918          else
 919             Position := (Container'Unchecked_Access, Before.Index);
 920          end if;
 921
 922          return;
 923       end if;
 924
 925       if Before.Container = null
 926         or else Before.Index > Container.Last
 927       then
 928          Index := Index_Type'Succ (Container.Last);
 929       else
 930          Index := Before.Index;
 931       end if;
 932
 933       Insert (Container, Index, New_Item, Count);
 934
 935       Position := Cursor'(Container'Unchecked_Access, Index);
 936    end Insert;
 937
 938    ------------------
 939    -- Insert_Space --
 940    ------------------
 941
 942    procedure Insert_Space
 943      (Container : in out Vector;
 944       Before    : Extended_Index;
 945       Count     : Count_Type := 1)
 946    is
 947       Old_Last : constant Extended_Index := Container.Last;
 948
 949       Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last);
 950
 951       N : constant Int := Count_Type'Pos (Count);
 952
 953       New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N;
 954
 955       New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int);
 956
 957       Index : Index_Type;
 958
 959       Dst_Last : Index_Type;
 960       Dst      : Elements_Access;
 961
 962    begin
 963       if Count = 0 then
 964          return;
 965       end if;
 966
 967       declare
 968          subtype Before_Subtype is Index_Type'Base range
 969            Index_Type'First .. Index_Type'Succ (Container.Last);
 970
 971          Old_First : constant Before_Subtype := Before;
 972
 973          Old_First_As_Int : constant Int := Index_Type'Pos (Old_First);
 974
 975          New_First_As_Int : constant Int'Base := Old_First_As_Int + N;
 976
 977       begin
 978          Index := Index_Type (New_First_As_Int);
 979       end;
 980
 981       if Container.Elements = null then
 982          Container.Elements :=
 983            new Elements_Type (Index_Type'First .. New_Last);
 984
 985          Container.Last := New_Last;
 986          return;
 987       end if;
 988
 989       if New_Last <= Container.Elements'Last then
 990          declare
 991             E : Elements_Type renames Container.Elements.all;
 992          begin
 993             E (Index .. New_Last) := E (Before .. Container.Last);
 994          end;
 995
 996          Container.Last := New_Last;
 997          return;
 998       end if;
 999
1000       declare
1001          First : constant Int := Int (Index_Type'First);
1002
1003          New_Size : constant Int'Base := New_Last_As_Int - First + 1;
1004          Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1;
1005
1006          Size, Dst_Last_As_Int : Int'Base;
1007
1008       begin
1009          if New_Size >= Max_Size / 2 then
1010             Dst_Last := Index_Type'Last;
1011
1012          else
1013             Size := Container.Elements'Length;
1014
1015             if Size = 0 then
1016                Size := 1;
1017             end if;
1018
1019             while Size < New_Size loop
1020                Size := 2 * Size;
1021             end loop;
1022
1023             Dst_Last_As_Int := First + Size - 1;
1024             Dst_Last := Index_Type (Dst_Last_As_Int);
1025          end if;
1026       end;
1027
1028       Dst := new Elements_Type (Index_Type'First .. Dst_Last);
1029
1030       declare
1031          Src : Elements_Type renames Container.Elements.all;
1032
1033       begin
1034          Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
1035            Src (Index_Type'First .. Index_Type'Pred (Before));
1036
1037          Dst (Index .. New_Last) :=
1038            Src (Before .. Container.Last);
1039
1040       exception
1041          when others =>
1042             Free (Dst);
1043             raise;
1044       end;
1045
1046       declare
1047          X : Elements_Access := Container.Elements;
1048       begin
1049          Container.Elements := Dst;
1050          Container.Last := New_Last;
1051
1052          Free (X);
1053       end;
1054    end Insert_Space;
1055
1056    procedure Insert_Space
1057      (Container : in out Vector;
1058       Before    : Cursor;
1059       Position  : out Cursor;
1060       Count     : Count_Type := 1)
1061    is
1062       Index : Index_Type'Base;
1063
1064    begin
1065       if Before.Container /= null
1066         and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1067       then
1068          raise Program_Error;
1069       end if;
1070
1071       if Count = 0 then
1072          if Before.Container = null
1073            or else Before.Index > Container.Last
1074          then
1075             Position := No_Element;
1076          else
1077             Position := (Container'Unchecked_Access, Before.Index);
1078          end if;
1079
1080          return;
1081       end if;
1082
1083       if Before.Container = null
1084         or else Before.Index > Container.Last
1085       then
1086          Index := Index_Type'Succ (Container.Last);
1087       else
1088          Index := Before.Index;
1089       end if;
1090
1091       Insert_Space (Container, Index, Count);
1092
1093       Position := Cursor'(Container'Unchecked_Access, Index);
1094    end Insert_Space;
1095
1096    --------------
1097    -- Is_Empty --
1098    --------------
1099
1100    function Is_Empty (Container : Vector) return Boolean is
1101    begin
1102       return Container.Last < Index_Type'First;
1103    end Is_Empty;
1104
1105    -------------
1106    -- Iterate --
1107    -------------
1108
1109    procedure Iterate
1110      (Container : Vector;
1111       Process   : not null access procedure (Position : Cursor))
1112    is
1113    begin
1114       for Indx in Index_Type'First .. Container.Last loop
1115          Process (Cursor'(Container'Unchecked_Access, Indx));
1116       end loop;
1117    end Iterate;
1118
1119    ----------
1120    -- Last --
1121    ----------
1122
1123    function Last (Container : Vector) return Cursor is
1124    begin
1125       if Is_Empty (Container) then
1126          return No_Element;
1127       end if;
1128
1129       return (Container'Unchecked_Access, Container.Last);
1130    end Last;
1131
1132    ------------------
1133    -- Last_Element --
1134    ------------------
1135
1136    function Last_Element (Container : Vector) return Element_Type is
1137    begin
1138       return Element (Container, Container.Last);
1139    end Last_Element;
1140
1141    ----------------
1142    -- Last_Index --
1143    ----------------
1144
1145    function Last_Index (Container : Vector) return Extended_Index is
1146    begin
1147       return Container.Last;
1148    end Last_Index;
1149
1150    ------------
1151    -- Length --
1152    ------------
1153
1154    function Length (Container : Vector) return Count_Type is
1155       L : constant Int := Int (Container.Last);
1156       F : constant Int := Int (Index_Type'First);
1157       N : constant Int'Base := L - F + 1;
1158    begin
1159       return Count_Type (N);
1160    end Length;
1161
1162    ----------
1163    -- Move --
1164    ----------
1165
1166    procedure Move
1167      (Target : in out Vector;
1168       Source : in out Vector)
1169    is
1170       X : Elements_Access := Target.Elements;
1171
1172    begin
1173       if Target'Address = Source'Address then
1174          return;
1175       end if;
1176
1177       if Target.Last >= Index_Type'First then
1178          raise Constraint_Error;
1179       end if;
1180
1181       Target.Elements := null;
1182       Free (X);
1183
1184       Target.Elements := Source.Elements;
1185       Target.Last := Source.Last;
1186
1187       Source.Elements := null;
1188       Source.Last := Index_Type'Pred (Index_Type'First);
1189    end Move;
1190
1191    ----------
1192    -- Next --
1193    ----------
1194
1195    function Next (Position : Cursor) return Cursor is
1196    begin
1197       if Position.Container = null then
1198          return No_Element;
1199       end if;
1200
1201       if Position.Index < Position.Container.Last then
1202          return (Position.Container, Index_Type'Succ (Position.Index));
1203       end if;
1204
1205       return No_Element;
1206    end Next;
1207
1208    ----------
1209    -- Next --
1210    ----------
1211
1212    procedure Next (Position : in out Cursor) is
1213    begin
1214       if Position.Container = null then
1215          return;
1216       end if;
1217
1218       if Position.Index < Position.Container.Last then
1219          Position.Index := Index_Type'Succ (Position.Index);
1220       else
1221          Position := No_Element;
1222       end if;
1223    end Next;
1224
1225    -------------
1226    -- Prepend --
1227    -------------
1228
1229    procedure Prepend (Container : in out Vector; New_Item : Vector) is
1230    begin
1231       Insert (Container, Index_Type'First, New_Item);
1232    end Prepend;
1233
1234    procedure Prepend
1235      (Container : in out Vector;
1236       New_Item  : Element_Type;
1237       Count     : Count_Type := 1)
1238    is
1239    begin
1240       Insert (Container,
1241               Index_Type'First,
1242               New_Item,
1243               Count);
1244    end Prepend;
1245
1246    --------------
1247    -- Previous --
1248    --------------
1249
1250    procedure Previous (Position : in out Cursor) is
1251    begin
1252       if Position.Container = null then
1253          return;
1254       end if;
1255
1256       if Position.Index > Index_Type'First then
1257          Position.Index := Index_Type'Pred (Position.Index);
1258       else
1259          Position := No_Element;
1260       end if;
1261    end Previous;
1262
1263    function Previous (Position : Cursor) return Cursor is
1264    begin
1265       if Position.Container = null then
1266          return No_Element;
1267       end if;
1268
1269       if Position.Index > Index_Type'First then
1270          return (Position.Container, Index_Type'Pred (Position.Index));
1271       end if;
1272
1273       return No_Element;
1274    end Previous;
1275
1276    -------------------
1277    -- Query_Element --
1278    -------------------
1279
1280    procedure Query_Element
1281      (Container : Vector;
1282       Index     : Index_Type;
1283       Process   : not null access procedure (Element : Element_Type))
1284    is
1285       subtype T is Index_Type'Base range
1286         Index_Type'First .. Container.Last;
1287    begin
1288       Process (Container.Elements (T'(Index)));
1289    end Query_Element;
1290
1291    procedure Query_Element
1292      (Position : Cursor;
1293       Process  : not null access procedure (Element : Element_Type))
1294    is
1295       Container : Vector renames Position.Container.all;
1296
1297       subtype T is Index_Type'Base range
1298         Index_Type'First .. Container.Last;
1299
1300    begin
1301       Process (Container.Elements (T'(Position.Index)));
1302    end Query_Element;
1303
1304    ----------
1305    -- Read --
1306    ----------
1307
1308    procedure Read
1309      (Stream    : access Root_Stream_Type'Class;
1310       Container : out Vector)
1311    is
1312       Length : Count_Type'Base;
1313       Last   : Index_Type'Base := Index_Type'Pred (Index_Type'First);
1314
1315    begin
1316       Clear (Container);
1317
1318       Count_Type'Base'Read (Stream, Length);
1319
1320       if Length > Capacity (Container) then
1321          Reserve_Capacity (Container, Capacity => Length);
1322       end if;
1323
1324       for J in Count_Type range 1 .. Length loop
1325          Last := Index_Type'Succ (Last);
1326          Element_Type'Read (Stream, Container.Elements (Last));
1327          Container.Last := Last;
1328       end loop;
1329    end Read;
1330
1331    ---------------------
1332    -- Replace_Element --
1333    ---------------------
1334
1335    procedure Replace_Element
1336      (Container : Vector;
1337       Index     : Index_Type;
1338       By        : Element_Type)
1339    is
1340       subtype T is Index_Type'Base range
1341         Index_Type'First .. Container.Last;
1342    begin
1343       Container.Elements (T'(Index)) := By;
1344    end Replace_Element;
1345
1346    procedure Replace_Element (Position : Cursor; By : Element_Type) is
1347       subtype T is Index_Type'Base range
1348         Index_Type'First .. Position.Container.Last;
1349    begin
1350       Position.Container.Elements (T'(Position.Index)) := By;
1351    end Replace_Element;
1352
1353    ----------------------
1354    -- Reserve_Capacity --
1355    ----------------------
1356
1357    procedure Reserve_Capacity
1358      (Container : in out Vector;
1359       Capacity  : Count_Type)
1360    is
1361       N : constant Count_Type := Length (Container);
1362
1363    begin
1364       if Capacity = 0 then
1365          if N = 0 then
1366             declare
1367                X : Elements_Access := Container.Elements;
1368             begin
1369                Container.Elements := null;
1370                Free (X);
1371             end;
1372
1373          elsif N < Container.Elements'Length then
1374             declare
1375                subtype Array_Index_Subtype is Index_Type'Base range
1376                  Index_Type'First .. Container.Last;
1377
1378                Src : Elements_Type renames
1379                        Container.Elements (Array_Index_Subtype);
1380
1381                subtype Array_Subtype is
1382                  Elements_Type (Array_Index_Subtype);
1383
1384                X : Elements_Access := Container.Elements;
1385
1386             begin
1387                Container.Elements := new Array_Subtype'(Src);
1388                Free (X);
1389             end;
1390          end if;
1391
1392          return;
1393       end if;
1394
1395       if Container.Elements = null then
1396          declare
1397             Last_As_Int : constant Int'Base :=
1398                             Int (Index_Type'First) + Int (Capacity) - 1;
1399
1400             Last : constant Index_Type := Index_Type (Last_As_Int);
1401
1402             subtype Array_Subtype is
1403               Elements_Type (Index_Type'First .. Last);
1404
1405          begin
1406             Container.Elements := new Array_Subtype;
1407          end;
1408
1409          return;
1410       end if;
1411
1412       if Capacity <= N then
1413          if N < Container.Elements'Length then
1414             declare
1415                subtype Array_Index_Subtype is Index_Type'Base range
1416                  Index_Type'First .. Container.Last;
1417
1418                Src : Elements_Type renames
1419                        Container.Elements (Array_Index_Subtype);
1420
1421                subtype Array_Subtype is
1422                  Elements_Type (Array_Index_Subtype);
1423
1424                X : Elements_Access := Container.Elements;
1425
1426             begin
1427                Container.Elements := new Array_Subtype'(Src);
1428                Free (X);
1429             end;
1430
1431          end if;
1432
1433          return;
1434       end if;
1435
1436       if Capacity = Container.Elements'Length then
1437          return;
1438       end if;
1439
1440       declare
1441          Last_As_Int : constant Int'Base :=
1442                          Int (Index_Type'First) + Int (Capacity) - 1;
1443
1444          Last : constant Index_Type := Index_Type (Last_As_Int);
1445
1446          subtype Array_Subtype is
1447            Elements_Type (Index_Type'First .. Last);
1448
1449          E : Elements_Access := new Array_Subtype;
1450
1451       begin
1452          declare
1453             Src : Elements_Type renames
1454                     Container.Elements (Index_Type'First .. Container.Last);
1455
1456             Tgt : Elements_Type renames
1457                     E (Index_Type'First .. Container.Last);
1458
1459          begin
1460             Tgt := Src;
1461
1462          exception
1463             when others =>
1464                Free (E);
1465                raise;
1466          end;
1467
1468          declare
1469             X : Elements_Access := Container.Elements;
1470          begin
1471             Container.Elements := E;
1472             Free (X);
1473          end;
1474       end;
1475    end Reserve_Capacity;
1476
1477    ------------------
1478    -- Reverse_Find --
1479    ------------------
1480
1481    function Reverse_Find
1482      (Container : Vector;
1483       Item      : Element_Type;
1484       Position  : Cursor := No_Element) return Cursor
1485    is
1486       Last : Index_Type'Base;
1487
1488    begin
1489       if Position.Container /= null
1490         and then Position.Container /=
1491                    Vector_Access'(Container'Unchecked_Access)
1492       then
1493          raise Program_Error;
1494       end if;
1495
1496       if Position.Container = null
1497         or else Position.Index > Container.Last
1498       then
1499          Last := Container.Last;
1500       else
1501          Last := Position.Index;
1502       end if;
1503
1504       for Indx in reverse Index_Type'First .. Last loop
1505          if Container.Elements (Indx) = Item then
1506             return (Container'Unchecked_Access, Indx);
1507          end if;
1508       end loop;
1509
1510       return No_Element;
1511    end Reverse_Find;
1512
1513    ------------------------
1514    -- Reverse_Find_Index --
1515    ------------------------
1516
1517    function Reverse_Find_Index
1518      (Container : Vector;
1519       Item      : Element_Type;
1520       Index     : Index_Type := Index_Type'Last) return Extended_Index
1521    is
1522       Last : Index_Type'Base;
1523
1524    begin
1525       if Index > Container.Last then
1526          Last := Container.Last;
1527       else
1528          Last := Index;
1529       end if;
1530
1531       for Indx in reverse Index_Type'First .. Last loop
1532          if Container.Elements (Indx) = Item then
1533             return Indx;
1534          end if;
1535       end loop;
1536
1537       return No_Index;
1538    end Reverse_Find_Index;
1539
1540    ---------------------
1541    -- Reverse_Iterate --
1542    ---------------------
1543
1544    procedure Reverse_Iterate
1545      (Container : Vector;
1546       Process   : not null access procedure (Position : Cursor))
1547    is
1548    begin
1549       for Indx in reverse Index_Type'First .. Container.Last loop
1550          Process (Cursor'(Container'Unchecked_Access, Indx));
1551       end loop;
1552    end Reverse_Iterate;
1553
1554    ----------------
1555    -- Set_Length --
1556    ----------------
1557
1558    procedure Set_Length (Container : in out Vector; Length : Count_Type) is
1559    begin
1560       if Length = 0 then
1561          Clear (Container);
1562          return;
1563       end if;
1564
1565       declare
1566          Last_As_Int : constant Int'Base :=
1567                          Int (Index_Type'First) + Int (Length) - 1;
1568
1569          Last        : constant Index_Type := Index_Type (Last_As_Int);
1570
1571       begin
1572          if Length > Capacity (Container) then
1573             Reserve_Capacity (Container, Capacity => Length);
1574          end if;
1575
1576          Container.Last := Last;
1577       end;
1578    end Set_Length;
1579
1580    ----------
1581    -- Swap --
1582    ----------
1583
1584    procedure Swap
1585      (Container : Vector;
1586       I, J      : Index_Type)
1587    is
1588
1589       subtype T is Index_Type'Base range
1590         Index_Type'First .. Container.Last;
1591
1592       EI : constant Element_Type := Container.Elements (T'(I));
1593
1594    begin
1595
1596       Container.Elements (T'(I)) := Container.Elements (T'(J));
1597       Container.Elements (T'(J)) := EI;
1598
1599    end Swap;
1600
1601    procedure Swap (I, J : Cursor) is
1602
1603       --  NOTE: The behavior has been liberalized here to
1604       --  allow I and J to designate different containers.
1605       --  TODO: Probably this is supposed to raise P_E ???
1606
1607       subtype TI is Index_Type'Base range
1608         Index_Type'First .. I.Container.Last;
1609
1610       EI : Element_Type renames I.Container.Elements (TI'(I.Index));
1611
1612       EI_Copy : constant Element_Type := EI;
1613
1614       subtype TJ is Index_Type'Base range
1615         Index_Type'First .. J.Container.Last;
1616
1617       EJ : Element_Type renames J.Container.Elements (TJ'(J.Index));
1618
1619    begin
1620       EI := EJ;
1621       EJ := EI_Copy;
1622    end Swap;
1623
1624    ---------------
1625    -- To_Cursor --
1626    ---------------
1627
1628    function To_Cursor
1629      (Container : Vector;
1630       Index     : Extended_Index) return Cursor
1631    is
1632    begin
1633       if Index not in Index_Type'First .. Container.Last then
1634          return No_Element;
1635       end if;
1636
1637       return Cursor'(Container'Unchecked_Access, Index);
1638    end To_Cursor;
1639
1640    --------------
1641    -- To_Index --
1642    --------------
1643
1644    function To_Index (Position : Cursor) return Extended_Index is
1645    begin
1646       if Position.Container = null then
1647          return No_Index;
1648       end if;
1649
1650       if Position.Index <= Position.Container.Last then
1651          return Position.Index;
1652       end if;
1653
1654       return No_Index;
1655    end To_Index;
1656
1657    ---------------
1658    -- To_Vector --
1659    ---------------
1660
1661    function To_Vector (Length : Count_Type) return Vector is
1662    begin
1663       if Length = 0 then
1664          return Empty_Vector;
1665       end if;
1666
1667       declare
1668          First       : constant Int := Int (Index_Type'First);
1669          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
1670          Last        : constant Index_Type := Index_Type (Last_As_Int);
1671          Elements    : constant Elements_Access :=
1672                          new Elements_Type (Index_Type'First .. Last);
1673       begin
1674          return (Controlled with Elements, Last);
1675       end;
1676    end To_Vector;
1677
1678    function To_Vector
1679      (New_Item : Element_Type;
1680       Length   : Count_Type) return Vector
1681    is
1682    begin
1683       if Length = 0 then
1684          return Empty_Vector;
1685       end if;
1686
1687       declare
1688          First       : constant Int := Int (Index_Type'First);
1689          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
1690          Last        : constant Index_Type := Index_Type (Last_As_Int);
1691          Elements    : constant Elements_Access :=
1692                          new Elements_Type'
1693                                    (Index_Type'First .. Last => New_Item);
1694       begin
1695          return (Controlled with Elements, Last);
1696       end;
1697    end To_Vector;
1698
1699    --------------------
1700    -- Update_Element --
1701    --------------------
1702
1703    procedure Update_Element
1704      (Container : Vector;
1705       Index     : Index_Type;
1706       Process   : not null access procedure (Element : in out Element_Type))
1707    is
1708       subtype T is Index_Type'Base range
1709         Index_Type'First .. Container.Last;
1710    begin
1711       Process (Container.Elements (T'(Index)));
1712    end Update_Element;
1713
1714    procedure Update_Element
1715      (Position : Cursor;
1716       Process  : not null access procedure (Element : in out Element_Type))
1717    is
1718       subtype T is Index_Type'Base range
1719         Index_Type'First .. Position.Container.Last;
1720    begin
1721       Process (Position.Container.Elements (T'(Position.Index)));
1722    end Update_Element;
1723
1724    -----------
1725    -- Write --
1726    -----------
1727
1728    procedure Write
1729      (Stream    : access Root_Stream_Type'Class;
1730       Container : Vector)
1731    is
1732    begin
1733       Count_Type'Base'Write (Stream, Length (Container));
1734
1735       for J in Index_Type'First .. Container.Last loop
1736          Element_Type'Write (Stream, Container.Elements (J));
1737       end loop;
1738    end Write;
1739
1740 end Ada.Containers.Vectors;
1741