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