gcc/ada/a-coinve.adb

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