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