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