gcc/ada/a-cofove.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --         A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2010-2013, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Ada.Containers.Generic_Array_Sort;
  29 with System; use type System.Address;
  30
  31 package body Ada.Containers.Formal_Vectors is
  32
  33    type Int is range System.Min_Int .. System.Max_Int;
  34    type UInt is mod System.Max_Binary_Modulus;
  35
  36    function Get_Element
  37      (Container : Vector;
  38       Position  : Count_Type) return Element_Type;
  39
  40    procedure Insert_Space
  41      (Container : in out Vector;
  42       Before    : Extended_Index;
  43       Count     : Count_Type := 1);
  44
  45    ---------
  46    -- "&" --
  47    ---------
  48
  49    function "&" (Left, Right : Vector) return Vector is
  50       LN : constant Count_Type := Length (Left);
  51       RN : constant Count_Type := Length (Right);
  52
  53    begin
  54       if LN = 0 then
  55          if RN = 0 then
  56             return Empty_Vector;
  57          end if;
  58
  59          declare
  60             E : constant Elements_Array (1 .. Length (Right)) :=
  61               Right.Elements (1 .. RN);
  62          begin
  63             return (Length (Right), E, Last => Right.Last, others => <>);
  64          end;
  65       end if;
  66
  67       if RN = 0 then
  68          declare
  69             E : constant Elements_Array (1 .. Length (Left)) :=
  70               Left.Elements (1 .. LN);
  71          begin
  72             return (Length (Left), E, Last => Left.Last, others => <>);
  73          end;
  74       end if;
  75
  76       declare
  77          N           : constant Int'Base := Int (LN) + Int (RN);
  78          Last_As_Int : Int'Base;
  79
  80       begin
  81          if Int (No_Index) > Int'Last - N then
  82             raise Constraint_Error with "new length is out of range";
  83          end if;
  84
  85          Last_As_Int := Int (No_Index) + N;
  86
  87          if Last_As_Int > Int (Index_Type'Last) then
  88             raise Constraint_Error with "new length is out of range";
  89          end if;
  90
  91          --  TODO: should check whether length > max capacity (cnt_t'last)  ???
  92
  93          declare
  94             Last : constant Index_Type := Index_Type (Last_As_Int);
  95
  96             LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN);
  97             RE : Elements_Array renames Right.Elements (1 .. RN);
  98
  99             Capacity : constant Count_Type := Length (Left) + Length (Right);
 100
 101          begin
 102             return (Capacity, LE & RE, Last => Last, others => <>);
 103          end;
 104       end;
 105    end "&";
 106
 107    function "&" (Left  : Vector; Right : Element_Type) return Vector is
 108       LN          : constant Count_Type := Length (Left);
 109       Last_As_Int : Int'Base;
 110
 111    begin
 112       if LN = 0 then
 113          return (1, (1 .. 1 => Right), Index_Type'First, others => <>);
 114       end if;
 115
 116       if Int (Index_Type'First) > Int'Last - Int (LN) then
 117          raise Constraint_Error with "new length is out of range";
 118       end if;
 119
 120       Last_As_Int := Int (Index_Type'First) + Int (LN);
 121
 122       if Last_As_Int > Int (Index_Type'Last) then
 123          raise Constraint_Error with "new length is out of range";
 124       end if;
 125
 126       declare
 127          Last : constant Index_Type := Index_Type (Last_As_Int);
 128          LE   : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN);
 129
 130          Capacity : constant Count_Type := Length (Left) + 1;
 131
 132       begin
 133          return (Capacity, LE & Right, Last => Last, others => <>);
 134       end;
 135    end "&";
 136
 137    function "&" (Left  : Element_Type; Right : Vector) return Vector is
 138       RN          : constant Count_Type := Length (Right);
 139       Last_As_Int : Int'Base;
 140
 141    begin
 142       if RN = 0 then
 143          return (1, (1 .. 1 => Left),
 144                  Index_Type'First, others => <>);
 145       end if;
 146
 147       if Int (Index_Type'First) > Int'Last - Int (RN) then
 148          raise Constraint_Error with "new length is out of range";
 149       end if;
 150
 151       Last_As_Int := Int (Index_Type'First) + Int (RN);
 152
 153       if Last_As_Int > Int (Index_Type'Last) then
 154          raise Constraint_Error with "new length is out of range";
 155       end if;
 156
 157       declare
 158          Last     : constant Index_Type := Index_Type (Last_As_Int);
 159          RE       : Elements_Array renames Right.Elements (1 .. RN);
 160          Capacity : constant Count_Type := 1 + Length (Right);
 161       begin
 162          return (Capacity, Left & RE, Last => Last, others => <>);
 163       end;
 164    end "&";
 165
 166    function "&" (Left, Right : Element_Type) return Vector is
 167    begin
 168       if Index_Type'First >= Index_Type'Last then
 169          raise Constraint_Error with "new length is out of range";
 170       end if;
 171
 172       declare
 173          Last : constant Index_Type := Index_Type'First + 1;
 174       begin
 175          return (2, (Left, Right), Last => Last, others => <>);
 176       end;
 177    end "&";
 178
 179    ---------
 180    -- "=" --
 181    ---------
 182
 183    function "=" (Left, Right : Vector) return Boolean is
 184    begin
 185       if Left'Address = Right'Address then
 186          return True;
 187       end if;
 188
 189       if Length (Left) /= Length (Right) then
 190          return False;
 191       end if;
 192
 193       for J in Count_Type range 1 .. Length (Left) loop
 194          if Get_Element (Left, J) /= Get_Element (Right, J) then
 195             return False;
 196          end if;
 197       end loop;
 198
 199       return True;
 200    end "=";
 201
 202    ------------
 203    -- Append --
 204    ------------
 205
 206    procedure Append (Container : in out Vector; New_Item : Vector) is
 207    begin
 208       if Is_Empty (New_Item) then
 209          return;
 210       end if;
 211
 212       if Container.Last = Index_Type'Last then
 213          raise Constraint_Error with "vector is already at its maximum length";
 214       end if;
 215
 216       Insert (Container, Container.Last + 1, New_Item);
 217    end Append;
 218
 219    procedure Append
 220      (Container : in out Vector;
 221       New_Item  : Element_Type;
 222       Count     : Count_Type := 1)
 223    is
 224    begin
 225       if Count = 0 then
 226          return;
 227       end if;
 228
 229       if Container.Last = Index_Type'Last then
 230          raise Constraint_Error with "vector is already at its maximum length";
 231       end if;
 232
 233       --  TODO: should check whether length > max capacity (cnt_t'last)  ???
 234
 235       Insert (Container, Container.Last + 1, New_Item, Count);
 236    end Append;
 237
 238    ------------
 239    -- Assign --
 240    ------------
 241
 242    procedure Assign (Target : in out Vector; Source : Vector) is
 243       LS : constant Count_Type := Length (Source);
 244
 245    begin
 246       if Target'Address = Source'Address then
 247          return;
 248       end if;
 249
 250       if Target.Capacity < LS then
 251          raise Constraint_Error;
 252       end if;
 253
 254       Clear (Target);
 255
 256       Target.Elements (1 .. LS) := Source.Elements (1 .. LS);
 257       Target.Last := Source.Last;
 258    end Assign;
 259
 260    --------------
 261    -- Capacity --
 262    --------------
 263
 264    function Capacity (Container : Vector) return Count_Type is
 265    begin
 266       return Container.Elements'Length;
 267    end Capacity;
 268
 269    -----------
 270    -- Clear --
 271    -----------
 272
 273    procedure Clear (Container : in out Vector) is
 274    begin
 275       Container.Last := No_Index;
 276    end Clear;
 277
 278    --------------
 279    -- Contains --
 280    --------------
 281
 282    function Contains
 283      (Container : Vector;
 284       Item      : Element_Type) return Boolean
 285    is
 286    begin
 287       return Find_Index (Container, Item) /= No_Index;
 288    end Contains;
 289
 290    ----------
 291    -- Copy --
 292    ----------
 293
 294    function Copy
 295      (Source   : Vector;
 296       Capacity : Count_Type := 0) return Vector
 297    is
 298       LS : constant Count_Type := Length (Source);
 299       C  : Count_Type;
 300
 301    begin
 302       if Capacity = 0 then
 303          C := LS;
 304       elsif Capacity >= LS and then Capacity in Capacity_Range then
 305          C := Capacity;
 306       else
 307          raise Capacity_Error;
 308       end if;
 309
 310       return Target : Vector (C) do
 311          Target.Elements (1 .. LS) := Source.Elements (1 .. LS);
 312          Target.Last := Source.Last;
 313       end return;
 314    end Copy;
 315
 316    ---------------------
 317    -- Current_To_Last --
 318    ---------------------
 319
 320    function Current_To_Last
 321      (Container : Vector;
 322       Current   : Cursor) return Vector
 323    is
 324       C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
 325
 326    begin
 327       if Current = No_Element then
 328          Clear (C);
 329          return C;
 330
 331       elsif not Has_Element (Container, Current) then
 332          raise Constraint_Error;
 333
 334       else
 335          while C.Last /= Container.Last - Current.Index + 1 loop
 336             Delete_First (C);
 337          end loop;
 338
 339          return C;
 340       end if;
 341    end Current_To_Last;
 342
 343    ------------
 344    -- Delete --
 345    ------------
 346
 347    procedure Delete
 348      (Container : in out Vector;
 349       Index     : Extended_Index;
 350       Count     : Count_Type := 1)
 351    is
 352    begin
 353       if Index < Index_Type'First then
 354          raise Constraint_Error with "Index is out of range (too small)";
 355       end if;
 356
 357       if Index > Container.Last then
 358          if Index > Container.Last + 1 then
 359             raise Constraint_Error with "Index is out of range (too large)";
 360          end if;
 361
 362          return;
 363       end if;
 364
 365       if Count = 0 then
 366          return;
 367       end if;
 368
 369       declare
 370          I_As_Int        : constant Int := Int (Index);
 371          Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
 372
 373          Count1 : constant Int'Base := Count_Type'Pos (Count);
 374          Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
 375          N      : constant Int'Base := Int'Min (Count1, Count2);
 376
 377          J_As_Int : constant Int'Base := I_As_Int + N;
 378
 379       begin
 380          if J_As_Int > Old_Last_As_Int then
 381             Container.Last := Index - 1;
 382
 383          else
 384             declare
 385                EA : Elements_Array renames Container.Elements;
 386
 387                II : constant Int'Base := I_As_Int - Int (No_Index);
 388                I  : constant Count_Type := Count_Type (II);
 389
 390                JJ : constant Int'Base := J_As_Int - Int (No_Index);
 391                J  : constant Count_Type := Count_Type (JJ);
 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                KK : constant Int := New_Last_As_Int - Int (No_Index);
 398                K  : constant Count_Type := Count_Type (KK);
 399
 400             begin
 401                EA (I .. K) := EA (J .. Length (Container));
 402                Container.Last := New_Last;
 403             end;
 404          end if;
 405       end;
 406    end Delete;
 407
 408    procedure Delete
 409      (Container : in out Vector;
 410       Position  : in out Cursor;
 411       Count     : Count_Type := 1)
 412    is
 413    begin
 414       if not Position.Valid then
 415          raise Constraint_Error with "Position cursor has no element";
 416       end if;
 417
 418       if Position.Index > Container.Last then
 419          raise Program_Error with "Position index is out of range";
 420       end if;
 421
 422       Delete (Container, Position.Index, Count);
 423       Position := No_Element;
 424    end Delete;
 425
 426    ------------------
 427    -- Delete_First --
 428    ------------------
 429
 430    procedure Delete_First
 431      (Container : in out Vector;
 432       Count     : Count_Type := 1)
 433    is
 434    begin
 435       if Count = 0 then
 436          return;
 437       end if;
 438
 439       if Count >= Length (Container) then
 440          Clear (Container);
 441          return;
 442       end if;
 443
 444       Delete (Container, Index_Type'First, Count);
 445    end Delete_First;
 446
 447    -----------------
 448    -- Delete_Last --
 449    -----------------
 450
 451    procedure Delete_Last
 452      (Container : in out Vector;
 453       Count     : Count_Type := 1)
 454    is
 455       Index : Int'Base;
 456
 457    begin
 458       if Count = 0 then
 459          return;
 460       end if;
 461
 462       Index := Int'Base (Container.Last) - Int'Base (Count);
 463
 464       if Index < Index_Type'Pos (Index_Type'First) then
 465          Container.Last := No_Index;
 466       else
 467          Container.Last := Index_Type (Index);
 468       end if;
 469    end Delete_Last;
 470
 471    -------------
 472    -- Element --
 473    -------------
 474
 475    function Element
 476      (Container : Vector;
 477       Index     : Index_Type) return Element_Type
 478    is
 479    begin
 480       if Index > Container.Last then
 481          raise Constraint_Error with "Index is out of range";
 482       end if;
 483
 484       declare
 485          II : constant Int'Base := Int (Index) - Int (No_Index);
 486          I  : constant Count_Type := Count_Type (II);
 487       begin
 488          return Get_Element (Container, I);
 489       end;
 490    end Element;
 491
 492    function Element
 493      (Container : Vector;
 494       Position  : Cursor) return Element_Type
 495    is
 496       Lst : constant Index_Type := Last_Index (Container);
 497
 498    begin
 499       if not Position.Valid then
 500          raise Constraint_Error with "Position cursor has no element";
 501       end if;
 502
 503       if Position.Index > Lst then
 504          raise Constraint_Error with "Position cursor is out of range";
 505       end if;
 506
 507       declare
 508          II : constant Int'Base := Int (Position.Index) - Int (No_Index);
 509          I  : constant Count_Type := Count_Type (II);
 510       begin
 511          return Get_Element (Container, I);
 512       end;
 513    end Element;
 514
 515    ----------
 516    -- Find --
 517    ----------
 518
 519    function Find
 520      (Container : Vector;
 521       Item      : Element_Type;
 522       Position  : Cursor := No_Element) return Cursor
 523    is
 524       K    : Count_Type;
 525       Last : constant Index_Type := Last_Index (Container);
 526
 527    begin
 528       if Position.Valid then
 529          if Position.Index > Last_Index (Container) then
 530             raise Program_Error with "Position index is out of range";
 531          end if;
 532       end if;
 533
 534       K := Count_Type (Int (Position.Index) - Int (No_Index));
 535
 536       for J in Position.Index .. Last loop
 537          if Get_Element (Container, K) = Item then
 538             return Cursor'(Index => J, others => <>);
 539          end if;
 540
 541          K := K + 1;
 542       end loop;
 543
 544       return No_Element;
 545    end Find;
 546
 547    ----------------
 548    -- Find_Index --
 549    ----------------
 550
 551    function Find_Index
 552      (Container : Vector;
 553       Item      : Element_Type;
 554       Index     : Index_Type := Index_Type'First) return Extended_Index
 555    is
 556       K    : Count_Type;
 557       Last : constant Index_Type := Last_Index (Container);
 558
 559    begin
 560       K := Count_Type (Int (Index) - Int (No_Index));
 561       for Indx in Index .. Last loop
 562          if Get_Element (Container, K) = Item then
 563             return Indx;
 564          end if;
 565
 566          K := K + 1;
 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 (True, 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       if Is_Empty (Container) then
 592          raise Constraint_Error with "Container is empty";
 593       end if;
 594
 595       return Get_Element (Container, 1);
 596    end First_Element;
 597
 598    -----------------
 599    -- First_Index --
 600    -----------------
 601
 602    function First_Index (Container : Vector) return Index_Type is
 603       pragma Unreferenced (Container);
 604    begin
 605       return Index_Type'First;
 606    end First_Index;
 607
 608    -----------------------
 609    -- First_To_Previous --
 610    -----------------------
 611
 612    function First_To_Previous
 613      (Container : Vector;
 614       Current   : Cursor) return Vector
 615    is
 616       C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
 617
 618    begin
 619       if Current = No_Element then
 620          return C;
 621
 622       elsif not Has_Element (Container, Current) then
 623          raise Constraint_Error;
 624
 625       else
 626          while C.Last /= Current.Index - 1 loop
 627             Delete_Last (C);
 628          end loop;
 629
 630          return C;
 631       end if;
 632    end First_To_Previous;
 633
 634    ---------------------
 635    -- Generic_Sorting --
 636    ---------------------
 637
 638    package body Generic_Sorting is
 639
 640       ---------------
 641       -- Is_Sorted --
 642       ---------------
 643
 644       function Is_Sorted (Container : Vector) return Boolean is
 645          Last : constant Index_Type := Last_Index (Container);
 646
 647       begin
 648          if Container.Last <= Last then
 649             return True;
 650          end if;
 651
 652          declare
 653             L : constant Count_Type := Length (Container);
 654          begin
 655             for J in Count_Type range 1 .. L - 1 loop
 656                if Get_Element (Container, J + 1) <
 657                   Get_Element (Container, J)
 658                then
 659                   return False;
 660                end if;
 661             end loop;
 662          end;
 663
 664          return True;
 665       end Is_Sorted;
 666
 667       -----------
 668       -- Merge --
 669       -----------
 670
 671       procedure Merge (Target, Source : in out Vector) is
 672       begin
 673          declare
 674             TA : Elements_Array renames Target.Elements;
 675             SA : Elements_Array renames Source.Elements;
 676
 677             I, J : Count_Type;
 678
 679          begin
 680             --  ???
 681             --           if Target.Last < Index_Type'First then
 682             --              Move (Target => Target, Source => Source);
 683             --              return;
 684             --           end if;
 685
 686             if Target'Address = Source'Address then
 687                return;
 688             end if;
 689
 690             if Source.Last < Index_Type'First then
 691                return;
 692             end if;
 693
 694             --  I think we're missing this check in a-convec.adb...  ???
 695
 696             I := Length (Target);
 697             Set_Length (Target, I + Length (Source));
 698
 699             J := Length (Target);
 700             while not Is_Empty (Source) loop
 701                pragma Assert (Length (Source) <= 1
 702                  or else not (SA (Length (Source)) <
 703                      SA (Length (Source) - 1)));
 704
 705                if I = 0 then
 706                   TA (1 .. J) := SA (1 .. Length (Source));
 707                   Source.Last := No_Index;
 708                   return;
 709                end if;
 710
 711                pragma Assert (I <= 1 or else not (TA (I) < TA (I - 1)));
 712
 713                if SA (Length (Source)) < TA (I) then
 714                   TA (J) := TA (I);
 715                   I := I - 1;
 716
 717                else
 718                   TA (J) := SA (Length (Source));
 719                   Source.Last := Source.Last - 1;
 720                end if;
 721
 722                J := J - 1;
 723             end loop;
 724          end;
 725       end Merge;
 726
 727       ----------
 728       -- Sort --
 729       ----------
 730
 731       procedure Sort (Container : in out Vector)
 732       is
 733          procedure Sort is
 734            new Generic_Array_Sort
 735              (Index_Type   => Count_Type,
 736               Element_Type => Element_Type,
 737               Array_Type   => Elements_Array,
 738               "<"          => "<");
 739
 740       begin
 741          if Container.Last <= Index_Type'First then
 742             return;
 743          end if;
 744
 745          Sort (Container.Elements (1 .. Length (Container)));
 746       end Sort;
 747
 748    end Generic_Sorting;
 749
 750    -----------------
 751    -- Get_Element --
 752    -----------------
 753
 754    function Get_Element
 755      (Container : Vector;
 756       Position  : Count_Type) return Element_Type
 757    is
 758    begin
 759       return Container.Elements (Position);
 760    end Get_Element;
 761
 762    -----------------
 763    -- Has_Element --
 764    -----------------
 765
 766    function Has_Element
 767      (Container : Vector;
 768       Position  : Cursor) return Boolean
 769    is
 770    begin
 771       if not Position.Valid then
 772          return False;
 773       else
 774          return Position.Index <= Last_Index (Container);
 775       end if;
 776    end Has_Element;
 777
 778    ------------
 779    -- Insert --
 780    ------------
 781
 782    procedure Insert
 783      (Container : in out Vector;
 784       Before    : Extended_Index;
 785       New_Item  : Element_Type;
 786       Count     : Count_Type := 1)
 787    is
 788       N : constant Int := Count_Type'Pos (Count);
 789
 790       First           : constant Int := Int (Index_Type'First);
 791       New_Last_As_Int : Int'Base;
 792       New_Last        : Index_Type;
 793       New_Length      : UInt;
 794       Max_Length      : constant UInt := UInt (Container.Capacity);
 795
 796    begin
 797       if Before < Index_Type'First then
 798          raise Constraint_Error with
 799            "Before index is out of range (too small)";
 800       end if;
 801
 802       if Before > Container.Last
 803         and then Before > Container.Last + 1
 804       then
 805          raise Constraint_Error with
 806            "Before index is out of range (too large)";
 807       end if;
 808
 809       if Count = 0 then
 810          return;
 811       end if;
 812
 813       declare
 814          Old_Last_As_Int : constant Int := Int (Container.Last);
 815
 816       begin
 817          if Old_Last_As_Int > Int'Last - N then
 818             raise Constraint_Error with "new length is out of range";
 819          end if;
 820
 821          New_Last_As_Int := Old_Last_As_Int + N;
 822
 823          if New_Last_As_Int > Int (Index_Type'Last) then
 824             raise Constraint_Error with "new length is out of range";
 825          end if;
 826
 827          New_Length := UInt (New_Last_As_Int - First + Int'(1));
 828
 829          if New_Length > Max_Length then
 830             raise Constraint_Error with "new length is out of range";
 831          end if;
 832
 833          New_Last := Index_Type (New_Last_As_Int);
 834
 835          --  Resolve issue of capacity vs. max index  ???
 836       end;
 837
 838       declare
 839          EA : Elements_Array renames Container.Elements;
 840
 841          BB : constant Int'Base := Int (Before) - Int (No_Index);
 842          B  : constant Count_Type := Count_Type (BB);
 843
 844          LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
 845          L  : constant Count_Type := Count_Type (LL);
 846
 847       begin
 848          if Before <= Container.Last then
 849             declare
 850                II : constant Int'Base := BB + N;
 851                I  : constant Count_Type := Count_Type (II);
 852             begin
 853                EA (I .. L) := EA (B .. Length (Container));
 854                EA (B .. I - 1) := (others => New_Item);
 855             end;
 856
 857          else
 858             EA (B .. L) := (others => New_Item);
 859          end if;
 860       end;
 861
 862       Container.Last := New_Last;
 863    end Insert;
 864
 865    procedure Insert
 866      (Container : in out Vector;
 867       Before    : Extended_Index;
 868       New_Item  : Vector)
 869    is
 870       N : constant Count_Type := Length (New_Item);
 871
 872    begin
 873       if Before < Index_Type'First then
 874          raise Constraint_Error with
 875            "Before index is out of range (too small)";
 876       end if;
 877
 878       if Before > Container.Last
 879         and then Before > Container.Last + 1
 880       then
 881          raise Constraint_Error with
 882            "Before index is out of range (too large)";
 883       end if;
 884
 885       if N = 0 then
 886          return;
 887       end if;
 888
 889       Insert_Space (Container, Before, Count => N);
 890
 891       declare
 892          Dst_Last_As_Int : constant Int'Base :=
 893            Int (Before) + Int (N) - 1 - Int (No_Index);
 894
 895          Dst_Last : constant Count_Type := Count_Type (Dst_Last_As_Int);
 896
 897          BB : constant Int'Base := Int (Before) - Int (No_Index);
 898          B  : constant Count_Type := Count_Type (BB);
 899
 900       begin
 901          if Container'Address /= New_Item'Address then
 902             Container.Elements (B .. Dst_Last) := New_Item.Elements (1 .. N);
 903             return;
 904          end if;
 905
 906          declare
 907             Src : Elements_Array renames Container.Elements (1 .. B - 1);
 908
 909             Index_As_Int : constant Int'Base := BB + Src'Length - 1;
 910
 911             Index : constant Count_Type := Count_Type (Index_As_Int);
 912
 913             Dst : Elements_Array renames Container.Elements (B .. Index);
 914
 915          begin
 916             Dst := Src;
 917          end;
 918
 919          if Dst_Last = Length (Container) then
 920             return;
 921          end if;
 922
 923          declare
 924             Src : Elements_Array renames
 925                     Container.Elements (Dst_Last + 1 .. Length (Container));
 926
 927             Index_As_Int : constant Int'Base :=
 928               Dst_Last_As_Int - Src'Length + 1;
 929
 930             Index : constant Count_Type := Count_Type (Index_As_Int);
 931
 932             Dst : Elements_Array renames
 933                     Container.Elements (Index .. Dst_Last);
 934
 935          begin
 936             Dst := Src;
 937          end;
 938       end;
 939    end Insert;
 940
 941    procedure Insert
 942      (Container : in out Vector;
 943       Before    : Cursor;
 944       New_Item  : Vector)
 945    is
 946       Index : Index_Type'Base;
 947
 948    begin
 949       if Is_Empty (New_Item) then
 950          return;
 951       end if;
 952
 953       if not Before.Valid
 954         or else Before.Index > Container.Last
 955       then
 956          if Container.Last = Index_Type'Last then
 957             raise Constraint_Error with
 958               "vector is already at its maximum length";
 959          end if;
 960
 961          Index := Container.Last + 1;
 962
 963       else
 964          Index := Before.Index;
 965       end if;
 966
 967       Insert (Container, Index, New_Item);
 968    end Insert;
 969
 970    procedure Insert
 971      (Container : in out Vector;
 972       Before    : Cursor;
 973       New_Item  : Vector;
 974       Position  : out Cursor)
 975    is
 976       Index : Index_Type'Base;
 977
 978    begin
 979       if Is_Empty (New_Item) then
 980          if not Before.Valid
 981            or else Before.Index > Container.Last
 982          then
 983             Position := No_Element;
 984          else
 985             Position := (True, Before.Index);
 986          end if;
 987
 988          return;
 989       end if;
 990
 991       if not Before.Valid
 992         or else Before.Index > Container.Last
 993       then
 994          if Container.Last = Index_Type'Last then
 995             raise Constraint_Error with
 996               "vector is already at its maximum length";
 997          end if;
 998
 999          Index := Container.Last + 1;
1000
1001       else
1002          Index := Before.Index;
1003       end if;
1004
1005       Insert (Container, Index, New_Item);
1006
1007       Position := Cursor'(True, Index);
1008    end Insert;
1009
1010    procedure Insert
1011      (Container : in out Vector;
1012       Before    : Cursor;
1013       New_Item  : Element_Type;
1014       Count     : Count_Type := 1)
1015    is
1016       Index : Index_Type'Base;
1017
1018    begin
1019       if Count = 0 then
1020          return;
1021       end if;
1022
1023       if not Before.Valid
1024         or else Before.Index > Container.Last
1025       then
1026          if Container.Last = Index_Type'Last then
1027             raise Constraint_Error with
1028               "vector is already at its maximum length";
1029          end if;
1030
1031          Index := Container.Last + 1;
1032
1033       else
1034          Index := Before.Index;
1035       end if;
1036
1037       Insert (Container, Index, New_Item, Count);
1038    end Insert;
1039
1040    procedure Insert
1041      (Container : in out Vector;
1042       Before    : Cursor;
1043       New_Item  : Element_Type;
1044       Position  : out Cursor;
1045       Count     : Count_Type := 1)
1046    is
1047       Index : Index_Type'Base;
1048
1049    begin
1050       if Count = 0 then
1051          if not Before.Valid
1052            or else Before.Index > Container.Last
1053          then
1054             Position := No_Element;
1055          else
1056             Position := (True, Before.Index);
1057          end if;
1058
1059          return;
1060       end if;
1061
1062       if not Before.Valid
1063         or else Before.Index > Container.Last
1064       then
1065          if Container.Last = Index_Type'Last then
1066             raise Constraint_Error with
1067               "vector is already at its maximum length";
1068          end if;
1069
1070          Index := Container.Last + 1;
1071
1072       else
1073          Index := Before.Index;
1074       end if;
1075
1076       Insert (Container, Index, New_Item, Count);
1077
1078       Position := Cursor'(True, Index);
1079    end Insert;
1080
1081    ------------------
1082    -- Insert_Space --
1083    ------------------
1084
1085    procedure Insert_Space
1086      (Container : in out Vector;
1087       Before    : Extended_Index;
1088       Count     : Count_Type := 1)
1089    is
1090       N : constant Int := Count_Type'Pos (Count);
1091
1092       First           : constant Int := Int (Index_Type'First);
1093       New_Last_As_Int : Int'Base;
1094       New_Last        : Index_Type;
1095       New_Length      : UInt;
1096       Max_Length      : constant UInt := UInt (Count_Type'Last);
1097
1098    begin
1099       if Before < Index_Type'First then
1100          raise Constraint_Error with
1101            "Before index is out of range (too small)";
1102       end if;
1103
1104       if Before > Container.Last
1105         and then Before > Container.Last + 1
1106       then
1107          raise Constraint_Error with
1108            "Before index is out of range (too large)";
1109       end if;
1110
1111       if Count = 0 then
1112          return;
1113       end if;
1114
1115       declare
1116          Old_Last_As_Int : constant Int := Int (Container.Last);
1117
1118       begin
1119          if Old_Last_As_Int > Int'Last - N then
1120             raise Constraint_Error with "new length is out of range";
1121          end if;
1122
1123          New_Last_As_Int := Old_Last_As_Int + N;
1124
1125          if New_Last_As_Int > Int (Index_Type'Last) then
1126             raise Constraint_Error with "new length is out of range";
1127          end if;
1128
1129          New_Length := UInt (New_Last_As_Int - First + Int'(1));
1130
1131          if New_Length > Max_Length then
1132             raise Constraint_Error with "new length is out of range";
1133          end if;
1134
1135          New_Last := Index_Type (New_Last_As_Int);
1136
1137          --  Resolve issue of capacity vs. max index  ???
1138       end;
1139
1140       declare
1141          EA : Elements_Array renames Container.Elements;
1142
1143          BB : constant Int'Base := Int (Before) - Int (No_Index);
1144          B  : constant Count_Type := Count_Type (BB);
1145
1146          LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
1147          L  : constant Count_Type := Count_Type (LL);
1148
1149       begin
1150          if Before <= Container.Last then
1151             declare
1152                II : constant Int'Base := BB + N;
1153                I  : constant Count_Type := Count_Type (II);
1154             begin
1155                EA (I .. L) := EA (B .. Length (Container));
1156             end;
1157          end if;
1158       end;
1159
1160       Container.Last := New_Last;
1161    end Insert_Space;
1162
1163    --------------
1164    -- Is_Empty --
1165    --------------
1166
1167    function Is_Empty (Container : Vector) return Boolean is
1168    begin
1169       return Last_Index (Container) < Index_Type'First;
1170    end Is_Empty;
1171
1172    ----------
1173    -- Last --
1174    ----------
1175
1176    function Last (Container : Vector) return Cursor is
1177    begin
1178       if Is_Empty (Container) then
1179          return No_Element;
1180       end if;
1181
1182       return (True, Last_Index (Container));
1183    end Last;
1184
1185    ------------------
1186    -- Last_Element --
1187    ------------------
1188
1189    function Last_Element (Container : Vector) return Element_Type is
1190    begin
1191       if Is_Empty (Container) then
1192          raise Constraint_Error with "Container is empty";
1193       end if;
1194
1195       return Get_Element (Container, Length (Container));
1196    end Last_Element;
1197
1198    ----------------
1199    -- Last_Index --
1200    ----------------
1201
1202    function Last_Index (Container : Vector) return Extended_Index is
1203    begin
1204       return Container.Last;
1205    end Last_Index;
1206
1207    ------------
1208    -- Length --
1209    ------------
1210
1211    function Length (Container : Vector) return Count_Type is
1212       L : constant Int := Int (Last_Index (Container));
1213       F : constant Int := Int (Index_Type'First);
1214       N : constant Int'Base := L - F + 1;
1215
1216    begin
1217       return Count_Type (N);
1218    end Length;
1219
1220    ----------
1221    -- Move --
1222    ----------
1223
1224    procedure Move
1225      (Target : in out Vector;
1226       Source : in out Vector)
1227    is
1228       N : constant Count_Type := Length (Source);
1229
1230    begin
1231       if Target'Address = Source'Address then
1232          return;
1233       end if;
1234
1235       if N > Target.Capacity then
1236          raise Constraint_Error with  -- correct exception here???
1237            "length of Source is greater than capacity of Target";
1238       end if;
1239
1240       --  We could also write this as a loop, and incrementally
1241       --  copy elements from source to target.
1242
1243       Target.Last := No_Index;  -- in case array assignment files
1244       Target.Elements (1 .. N) := Source.Elements (1 .. N);
1245
1246       Target.Last := Source.Last;
1247       Source.Last := No_Index;
1248    end Move;
1249
1250    ----------
1251    -- Next --
1252    ----------
1253
1254    function Next (Container : Vector; Position : Cursor) return Cursor is
1255    begin
1256       if not Position.Valid then
1257          return No_Element;
1258       end if;
1259
1260       if Position.Index < Last_Index (Container) then
1261          return (True, Position.Index + 1);
1262       end if;
1263
1264       return No_Element;
1265    end Next;
1266
1267    ----------
1268    -- Next --
1269    ----------
1270
1271    procedure Next (Container : Vector; Position : in out Cursor) is
1272    begin
1273       if not Position.Valid then
1274          return;
1275       end if;
1276
1277       if Position.Index < Last_Index (Container) then
1278          Position.Index := Position.Index + 1;
1279       else
1280          Position := No_Element;
1281       end if;
1282    end Next;
1283
1284    -------------
1285    -- Prepend --
1286    -------------
1287
1288    procedure Prepend (Container : in out Vector; New_Item : Vector) is
1289    begin
1290       Insert (Container, Index_Type'First, New_Item);
1291    end Prepend;
1292
1293    procedure Prepend
1294      (Container : in out Vector;
1295       New_Item  : Element_Type;
1296       Count     : Count_Type := 1)
1297    is
1298    begin
1299       Insert (Container,
1300               Index_Type'First,
1301               New_Item,
1302               Count);
1303    end Prepend;
1304
1305    --------------
1306    -- Previous --
1307    --------------
1308
1309    procedure Previous (Container : Vector; Position : in out Cursor) is
1310    begin
1311       if not Position.Valid then
1312          return;
1313       end if;
1314
1315       if Position.Index > Index_Type'First
1316         and then Position.Index <= Last_Index (Container)
1317       then
1318          Position.Index := Position.Index - 1;
1319       else
1320          Position := No_Element;
1321       end if;
1322    end Previous;
1323
1324    function Previous (Container : Vector; Position : Cursor) return Cursor is
1325    begin
1326       if not Position.Valid then
1327          return No_Element;
1328       end if;
1329
1330       if Position.Index > Index_Type'First
1331         and then Position.Index <= Last_Index (Container)
1332       then
1333          return (True, Position.Index - 1);
1334       end if;
1335
1336       return No_Element;
1337    end Previous;
1338
1339    ---------------------
1340    -- Replace_Element --
1341    ---------------------
1342
1343    procedure Replace_Element
1344      (Container : in out Vector;
1345       Index     : Index_Type;
1346       New_Item  : Element_Type)
1347    is
1348    begin
1349       if Index > Container.Last then
1350          raise Constraint_Error with "Index is out of range";
1351       end if;
1352
1353       declare
1354          II : constant Int'Base := Int (Index) - Int (No_Index);
1355          I  : constant Count_Type := Count_Type (II);
1356
1357       begin
1358          Container.Elements (I) := New_Item;
1359       end;
1360    end Replace_Element;
1361
1362    procedure Replace_Element
1363      (Container : in out Vector;
1364       Position  : Cursor;
1365       New_Item  : Element_Type)
1366    is
1367    begin
1368       if not Position.Valid then
1369          raise Constraint_Error with "Position cursor has no element";
1370       end if;
1371
1372       if Position.Index > Container.Last then
1373          raise Constraint_Error with "Position cursor is out of range";
1374       end if;
1375
1376       declare
1377          II : constant Int'Base := Int (Position.Index) - Int (No_Index);
1378          I  : constant Count_Type := Count_Type (II);
1379       begin
1380          Container.Elements (I) := New_Item;
1381       end;
1382    end Replace_Element;
1383
1384    ----------------------
1385    -- Reserve_Capacity --
1386    ----------------------
1387
1388    procedure Reserve_Capacity
1389      (Container : in out Vector;
1390       Capacity  : Count_Type)
1391    is
1392    begin
1393       if Capacity > Container.Capacity then
1394          raise Constraint_Error with "Capacity is out of range";
1395       end if;
1396    end Reserve_Capacity;
1397
1398    ----------------------
1399    -- Reverse_Elements --
1400    ----------------------
1401
1402    procedure Reverse_Elements (Container : in out Vector) is
1403    begin
1404       if Length (Container) <= 1 then
1405          return;
1406       end if;
1407
1408       declare
1409          I, J : Count_Type;
1410          E    : Elements_Array renames Container.Elements;
1411
1412       begin
1413          I := 1;
1414          J := Length (Container);
1415          while I < J loop
1416             declare
1417                EI : constant Element_Type := E (I);
1418             begin
1419                E (I) := E (J);
1420                E (J) := EI;
1421             end;
1422
1423             I := I + 1;
1424             J := J - 1;
1425          end loop;
1426       end;
1427    end Reverse_Elements;
1428
1429    ------------------
1430    -- Reverse_Find --
1431    ------------------
1432
1433    function Reverse_Find
1434      (Container : Vector;
1435       Item      : Element_Type;
1436       Position  : Cursor := No_Element) return Cursor
1437    is
1438       Last : Index_Type'Base;
1439       K    : Count_Type;
1440
1441    begin
1442       if not Position.Valid
1443         or else Position.Index > Last_Index (Container)
1444       then
1445          Last := Last_Index (Container);
1446       else
1447          Last := Position.Index;
1448       end if;
1449
1450       K := Count_Type (Int (Last) - Int (No_Index));
1451       for Indx in reverse Index_Type'First .. Last loop
1452          if Get_Element (Container, K) = Item then
1453             return (True, Indx);
1454          end if;
1455
1456          K := K - 1;
1457       end loop;
1458
1459       return No_Element;
1460    end Reverse_Find;
1461
1462    ------------------------
1463    -- Reverse_Find_Index --
1464    ------------------------
1465
1466    function Reverse_Find_Index
1467      (Container : Vector;
1468       Item      : Element_Type;
1469       Index     : Index_Type := Index_Type'Last) return Extended_Index
1470    is
1471       Last : Index_Type'Base;
1472       K    : Count_Type;
1473
1474    begin
1475       if Index > Last_Index (Container) then
1476          Last := Last_Index (Container);
1477       else
1478          Last := Index;
1479       end if;
1480
1481       K := Count_Type (Int (Last) - Int (No_Index));
1482       for Indx in reverse Index_Type'First .. Last loop
1483          if Get_Element (Container, K) = Item then
1484             return Indx;
1485          end if;
1486
1487          K := K - 1;
1488       end loop;
1489
1490       return No_Index;
1491    end Reverse_Find_Index;
1492
1493    ----------------
1494    -- Set_Length --
1495    ----------------
1496
1497    procedure Set_Length
1498      (Container : in out Vector;
1499       New_Length    : Count_Type)
1500    is
1501    begin
1502       if New_Length = Formal_Vectors.Length (Container) then
1503          return;
1504       end if;
1505
1506       if New_Length > Container.Capacity then
1507          raise Constraint_Error;  -- ???
1508       end if;
1509
1510       declare
1511          Last_As_Int : constant Int'Base :=
1512            Int (Index_Type'First) + Int (New_Length) - 1;
1513       begin
1514          Container.Last := Index_Type'Base (Last_As_Int);
1515       end;
1516    end Set_Length;
1517
1518    ------------------
1519    -- Strict_Equal --
1520    ------------------
1521
1522    function Strict_Equal (Left, Right : Vector) return Boolean is
1523    begin
1524       --  On bounded vectors, cursors are indexes. As a consequence, two
1525       --  vectors always have the same cursor at the same position and
1526       --  Strict_Equal is simply =
1527
1528       return Left = Right;
1529    end Strict_Equal;
1530
1531    ----------
1532    -- Swap --
1533    ----------
1534
1535    procedure Swap (Container : in out Vector; I, J : Index_Type) is
1536    begin
1537       if I > Container.Last then
1538          raise Constraint_Error with "I index is out of range";
1539       end if;
1540
1541       if J > Container.Last then
1542          raise Constraint_Error with "J index is out of range";
1543       end if;
1544
1545       if I = J then
1546          return;
1547       end if;
1548
1549       declare
1550          II : constant Int'Base := Int (I) - Int (No_Index);
1551          JJ : constant Int'Base := Int (J) - Int (No_Index);
1552
1553          EI : Element_Type renames Container.Elements (Count_Type (II));
1554          EJ : Element_Type renames Container.Elements (Count_Type (JJ));
1555
1556          EI_Copy : constant Element_Type := EI;
1557
1558       begin
1559          EI := EJ;
1560          EJ := EI_Copy;
1561       end;
1562    end Swap;
1563
1564    procedure Swap (Container : in out Vector; I, J : Cursor) is
1565    begin
1566       if not I.Valid then
1567          raise Constraint_Error with "I cursor has no element";
1568       end if;
1569
1570       if not J.Valid then
1571          raise Constraint_Error with "J cursor has no element";
1572       end if;
1573
1574       Swap (Container, I.Index, J.Index);
1575    end Swap;
1576
1577    ---------------
1578    -- To_Cursor --
1579    ---------------
1580
1581    function To_Cursor
1582      (Container : Vector;
1583       Index     : Extended_Index) return Cursor
1584    is
1585    begin
1586       if Index not in Index_Type'First .. Last_Index (Container) then
1587          return No_Element;
1588       end if;
1589
1590       return Cursor'(True, Index);
1591    end To_Cursor;
1592
1593    --------------
1594    -- To_Index --
1595    --------------
1596
1597    function To_Index (Position : Cursor) return Extended_Index is
1598    begin
1599       if not Position.Valid then
1600          return No_Index;
1601       end if;
1602
1603       return Position.Index;
1604    end To_Index;
1605
1606    ---------------
1607    -- To_Vector --
1608    ---------------
1609
1610    function To_Vector
1611      (New_Item : Element_Type;
1612       Length   : Count_Type) return Vector
1613    is
1614    begin
1615       if Length = 0 then
1616          return Empty_Vector;
1617       end if;
1618
1619       declare
1620          First       : constant Int := Int (Index_Type'First);
1621          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
1622          Last        : Index_Type;
1623
1624       begin
1625          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1626             raise Constraint_Error with "Length is out of range";  -- ???
1627          end if;
1628
1629          Last := Index_Type (Last_As_Int);
1630
1631          return (Length, (others => New_Item), Last => Last,
1632                  others => <>);
1633       end;
1634    end To_Vector;
1635
1636 end Ada.Containers.Formal_Vectors;