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