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
1175          else
1176             CC := UInt (Int (Index_Type'Last) - First + 1);
1177          end if;
1178
1179          if C > CC then
1180             C := CC;
1181          end if;
1182
1183          declare
1184             Dst_Last : constant Index_Type :=
1185                          Index_Type (First + UInt'Pos (C) - Int'(1));
1186
1187          begin
1188             Dst := new Elements_Type (Dst_Last);
1189          end;
1190       end;
1191
1192       if Before <= Container.Last then
1193          declare
1194             Index_As_Int : constant Int'Base :=
1195                              Index_Type'Pos (Before) + N;
1196
1197             Index : constant Index_Type := Index_Type (Index_As_Int);
1198
1199             Src : Elements_Access := Container.Elements;
1200
1201          begin
1202             Dst.EA (Index_Type'First .. Before - 1) :=
1203               Src.EA (Index_Type'First .. Before - 1);
1204
1205             Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
1206
1207             Container.Elements := Dst;
1208             Container.Last := New_Last;
1209             Free (Src);
1210
1211             for J in Before .. Index - 1 loop
1212                Dst.EA (J) := new Element_Type'(New_Item);
1213             end loop;
1214          end;
1215
1216       else
1217          declare
1218             Src : Elements_Access := Container.Elements;
1219
1220          begin
1221             Dst.EA (Index_Type'First .. Container.Last) :=
1222               Src.EA (Index_Type'First .. Container.Last);
1223
1224             Container.Elements := Dst;
1225             Free (Src);
1226
1227             for J in Before .. New_Last loop
1228                Dst.EA (J) := new Element_Type'(New_Item);
1229                Container.Last := J;
1230             end loop;
1231          end;
1232       end if;
1233    end Insert;
1234
1235    procedure Insert
1236      (Container : in out Vector;
1237       Before    : Extended_Index;
1238       New_Item  : Vector)
1239    is
1240       N : constant Count_Type := Length (New_Item);
1241
1242    begin
1243       if Before < Index_Type'First then
1244          raise Constraint_Error with
1245            "Before index is out of range (too small)";
1246       end if;
1247
1248       if Before > Container.Last
1249         and then Before > Container.Last + 1
1250       then
1251          raise Constraint_Error with
1252            "Before index is out of range (too large)";
1253       end if;
1254
1255       if N = 0 then
1256          return;
1257       end if;
1258
1259       Insert_Space (Container, Before, Count => N);
1260
1261       declare
1262          Dst_Last_As_Int : constant Int'Base :=
1263                              Int'Base (Before) + Int'Base (N) - 1;
1264
1265          Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
1266
1267          Dst : Elements_Array renames
1268                  Container.Elements.EA (Before .. Dst_Last);
1269
1270          Dst_Index : Index_Type'Base := Before - 1;
1271
1272       begin
1273          if Container'Address /= New_Item'Address then
1274             declare
1275                subtype Src_Index_Subtype is Index_Type'Base range
1276                  Index_Type'First .. New_Item.Last;
1277
1278                Src : Elements_Array renames
1279                        New_Item.Elements.EA (Src_Index_Subtype);
1280
1281             begin
1282                for Src_Index in Src'Range loop
1283                   Dst_Index := Dst_Index + 1;
1284
1285                   if Src (Src_Index) /= null then
1286                      Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1287                   end if;
1288                end loop;
1289             end;
1290
1291             return;
1292          end if;
1293
1294          declare
1295             subtype Src_Index_Subtype is Index_Type'Base range
1296               Index_Type'First .. Before - 1;
1297
1298             Src : Elements_Array renames
1299                     Container.Elements.EA (Src_Index_Subtype);
1300
1301          begin
1302             for Src_Index in Src'Range loop
1303                Dst_Index := Dst_Index + 1;
1304
1305                if Src (Src_Index) /= null then
1306                   Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1307                end if;
1308             end loop;
1309          end;
1310
1311          if Dst_Last = Container.Last then
1312             return;
1313          end if;
1314
1315          declare
1316             subtype Src_Index_Subtype is Index_Type'Base range
1317               Dst_Last + 1 .. Container.Last;
1318
1319             Src : Elements_Array renames
1320                     Container.Elements.EA (Src_Index_Subtype);
1321
1322          begin
1323             for Src_Index in Src'Range loop
1324                Dst_Index := Dst_Index + 1;
1325
1326                if Src (Src_Index) /= null then
1327                   Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1328                end if;
1329             end loop;
1330          end;
1331       end;
1332    end Insert;
1333
1334    procedure Insert
1335      (Container : in out Vector;
1336       Before    : Cursor;
1337       New_Item  : Vector)
1338    is
1339       Index : Index_Type'Base;
1340
1341    begin
1342       if Before.Container /= null
1343         and then Before.Container /= Container'Unchecked_Access
1344       then
1345          raise Program_Error with "Before cursor denotes wrong container";
1346       end if;
1347
1348       if Is_Empty (New_Item) then
1349          return;
1350       end if;
1351
1352       if Before.Container = null
1353         or else Before.Index > Container.Last
1354       then
1355          if Container.Last = Index_Type'Last then
1356             raise Constraint_Error with
1357               "vector is already at its maximum length";
1358          end if;
1359
1360          Index := Container.Last + 1;
1361
1362       else
1363          Index := Before.Index;
1364       end if;
1365
1366       Insert (Container, Index, New_Item);
1367    end Insert;
1368
1369    procedure Insert
1370      (Container : in out Vector;
1371       Before    : Cursor;
1372       New_Item  : Vector;
1373       Position  : out Cursor)
1374    is
1375       Index : Index_Type'Base;
1376
1377    begin
1378       if Before.Container /= null
1379         and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1380       then
1381          raise Program_Error with "Before cursor denotes wrong container";
1382       end if;
1383
1384       if Is_Empty (New_Item) then
1385          if Before.Container = null
1386            or else Before.Index > Container.Last
1387          then
1388             Position := No_Element;
1389          else
1390             Position := (Container'Unchecked_Access, Before.Index);
1391          end if;
1392
1393          return;
1394       end if;
1395
1396       if Before.Container = null
1397         or else Before.Index > Container.Last
1398       then
1399          if Container.Last = Index_Type'Last then
1400             raise Constraint_Error with
1401               "vector is already at its maximum length";
1402          end if;
1403
1404          Index := Container.Last + 1;
1405
1406       else
1407          Index := Before.Index;
1408       end if;
1409
1410       Insert (Container, Index, New_Item);
1411
1412       Position := Cursor'(Container'Unchecked_Access, Index);
1413    end Insert;
1414
1415    procedure Insert
1416      (Container : in out Vector;
1417       Before    : Cursor;
1418       New_Item  : Element_Type;
1419       Count     : Count_Type := 1)
1420    is
1421       Index : Index_Type'Base;
1422
1423    begin
1424       if Before.Container /= null
1425         and then Before.Container /= Container'Unchecked_Access
1426       then
1427          raise Program_Error with "Before cursor denotes wrong container";
1428       end if;
1429
1430       if Count = 0 then
1431          return;
1432       end if;
1433
1434       if Before.Container = null
1435         or else Before.Index > Container.Last
1436       then
1437          if Container.Last = Index_Type'Last then
1438             raise Constraint_Error with
1439               "vector is already at its maximum length";
1440          end if;
1441
1442          Index := Container.Last + 1;
1443
1444       else
1445          Index := Before.Index;
1446       end if;
1447
1448       Insert (Container, Index, New_Item, Count);
1449    end Insert;
1450
1451    procedure Insert
1452      (Container : in out Vector;
1453       Before    : Cursor;
1454       New_Item  : Element_Type;
1455       Position  : out Cursor;
1456       Count     : Count_Type := 1)
1457    is
1458       Index : Index_Type'Base;
1459
1460    begin
1461       if Before.Container /= null
1462         and then Before.Container /= Container'Unchecked_Access
1463       then
1464          raise Program_Error with "Before cursor denotes wrong container";
1465       end if;
1466
1467       if Count = 0 then
1468          if Before.Container = null
1469            or else Before.Index > Container.Last
1470          then
1471             Position := No_Element;
1472          else
1473             Position := (Container'Unchecked_Access, Before.Index);
1474          end if;
1475
1476          return;
1477       end if;
1478
1479       if Before.Container = null
1480         or else Before.Index > Container.Last
1481       then
1482          if Container.Last = Index_Type'Last then
1483             raise Constraint_Error with
1484               "vector is already at its maximum length";
1485          end if;
1486
1487          Index := Container.Last + 1;
1488
1489       else
1490          Index := Before.Index;
1491       end if;
1492
1493       Insert (Container, Index, New_Item, Count);
1494
1495       Position := (Container'Unchecked_Access, Index);
1496    end Insert;
1497
1498    ------------------
1499    -- Insert_Space --
1500    ------------------
1501
1502    procedure Insert_Space
1503      (Container : in out Vector;
1504       Before    : Extended_Index;
1505       Count     : Count_Type := 1)
1506    is
1507       N               : constant Int := Int (Count);
1508
1509       First           : constant Int := Int (Index_Type'First);
1510       New_Last_As_Int : Int'Base;
1511       New_Last        : Index_Type;
1512       New_Length      : UInt;
1513       Max_Length      : constant UInt := UInt (Count_Type'Last);
1514
1515       Dst             : Elements_Access;
1516
1517    begin
1518       if Before < Index_Type'First then
1519          raise Constraint_Error with
1520            "Before index is out of range (too small)";
1521       end if;
1522
1523       if Before > Container.Last
1524         and then Before > Container.Last + 1
1525       then
1526          raise Constraint_Error with
1527            "Before index is out of range (too large)";
1528       end if;
1529
1530       if Count = 0 then
1531          return;
1532       end if;
1533
1534       declare
1535          Old_Last_As_Int : constant Int := Int (Container.Last);
1536
1537       begin
1538          if Old_Last_As_Int > Int'Last - N then
1539             raise Constraint_Error with "new length is out of range";
1540          end if;
1541
1542          New_Last_As_Int := Old_Last_As_Int + N;
1543
1544          if New_Last_As_Int > Int (Index_Type'Last) then
1545             raise Constraint_Error with "new length is out of range";
1546          end if;
1547
1548          New_Length := UInt (New_Last_As_Int - First + 1);
1549
1550          if New_Length > Max_Length then
1551             raise Constraint_Error with "new length is out of range";
1552          end if;
1553
1554          New_Last := Index_Type (New_Last_As_Int);
1555       end;
1556
1557       if Container.Busy > 0 then
1558          raise Program_Error with
1559            "attempt to tamper with elements (vector is busy)";
1560       end if;
1561
1562       if Container.Elements = null then
1563          Container.Elements := new Elements_Type (New_Last);
1564          Container.Last := New_Last;
1565          return;
1566       end if;
1567
1568       if New_Last <= Container.Elements.Last then
1569          declare
1570             E : Elements_Array renames Container.Elements.EA;
1571
1572          begin
1573             if Before <= Container.Last then
1574                declare
1575                   Index_As_Int : constant Int'Base :=
1576                                    Index_Type'Pos (Before) + N;
1577
1578                   Index : constant Index_Type := Index_Type (Index_As_Int);
1579
1580                begin
1581                   E (Index .. New_Last) := E (Before .. Container.Last);
1582                   E (Before .. Index - 1) := (others => null);
1583                end;
1584             end if;
1585          end;
1586
1587          Container.Last := New_Last;
1588          return;
1589       end if;
1590
1591       declare
1592          C, CC : UInt;
1593
1594       begin
1595          C := UInt'Max (1, Container.Elements.EA'Length);  -- ???
1596          while C < New_Length loop
1597             if C > UInt'Last / 2 then
1598                C := UInt'Last;
1599                exit;
1600             end if;
1601
1602             C := 2 * C;
1603          end loop;
1604
1605          if C > Max_Length then
1606             C := Max_Length;
1607          end if;
1608
1609          if Index_Type'First <= 0
1610            and then Index_Type'Last >= 0
1611          then
1612             CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1;
1613
1614          else
1615             CC := UInt (Int (Index_Type'Last) - First + 1);
1616          end if;
1617
1618          if C > CC then
1619             C := CC;
1620          end if;
1621
1622          declare
1623             Dst_Last : constant Index_Type :=
1624                          Index_Type (First + UInt'Pos (C) - 1);
1625
1626          begin
1627             Dst := new Elements_Type (Dst_Last);
1628          end;
1629       end;
1630
1631       declare
1632          Src : Elements_Access := Container.Elements;
1633
1634       begin
1635          if Before <= Container.Last then
1636             declare
1637                Index_As_Int : constant Int'Base :=
1638                                 Index_Type'Pos (Before) + N;
1639
1640                Index : constant Index_Type := Index_Type (Index_As_Int);
1641
1642             begin
1643                Dst.EA (Index_Type'First .. Before - 1) :=
1644                  Src.EA (Index_Type'First .. Before - 1);
1645
1646                Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
1647             end;
1648
1649          else
1650             Dst.EA (Index_Type'First .. Container.Last) :=
1651               Src.EA (Index_Type'First .. Container.Last);
1652          end if;
1653
1654          Container.Elements := Dst;
1655          Container.Last := New_Last;
1656          Free (Src);
1657       end;
1658    end Insert_Space;
1659
1660    procedure Insert_Space
1661      (Container : in out Vector;
1662       Before    : Cursor;
1663       Position  : out Cursor;
1664       Count     : Count_Type := 1)
1665    is
1666       Index : Index_Type'Base;
1667
1668    begin
1669       if Before.Container /= null
1670         and then Before.Container /= Container'Unchecked_Access
1671       then
1672          raise Program_Error with "Before cursor denotes wrong container";
1673       end if;
1674
1675       if Count = 0 then
1676          if Before.Container = null
1677            or else Before.Index > Container.Last
1678          then
1679             Position := No_Element;
1680          else
1681             Position := (Container'Unchecked_Access, Before.Index);
1682          end if;
1683
1684          return;
1685       end if;
1686
1687       if Before.Container = null
1688         or else Before.Index > Container.Last
1689       then
1690          if Container.Last = Index_Type'Last then
1691             raise Constraint_Error with
1692               "vector is already at its maximum length";
1693          end if;
1694
1695          Index := Container.Last + 1;
1696
1697       else
1698          Index := Before.Index;
1699       end if;
1700
1701       Insert_Space (Container, Index, Count);
1702
1703       Position := Cursor'(Container'Unchecked_Access, Index);
1704    end Insert_Space;
1705
1706    --------------
1707    -- Is_Empty --
1708    --------------
1709
1710    function Is_Empty (Container : Vector) return Boolean is
1711    begin
1712       return Container.Last < Index_Type'First;
1713    end Is_Empty;
1714
1715    -------------
1716    -- Iterate --
1717    -------------
1718
1719    procedure Iterate
1720      (Container : Vector;
1721       Process   : not null access procedure (Position : Cursor))
1722    is
1723       V : Vector renames Container'Unrestricted_Access.all;
1724       B : Natural renames V.Busy;
1725
1726    begin
1727       B := B + 1;
1728
1729       begin
1730          for Indx in Index_Type'First .. Container.Last loop
1731             Process (Cursor'(Container'Unchecked_Access, Indx));
1732          end loop;
1733       exception
1734          when others =>
1735             B := B - 1;
1736             raise;
1737       end;
1738
1739       B := B - 1;
1740    end Iterate;
1741
1742    ----------
1743    -- Last --
1744    ----------
1745
1746    function Last (Container : Vector) return Cursor is
1747    begin
1748       if Is_Empty (Container) then
1749          return No_Element;
1750       end if;
1751
1752       return (Container'Unchecked_Access, Container.Last);
1753    end Last;
1754
1755    ------------------
1756    -- Last_Element --
1757    ------------------
1758
1759    function Last_Element (Container : Vector) return Element_Type is
1760    begin
1761       if Container.Last = No_Index then
1762          raise Constraint_Error with "Container is empty";
1763       end if;
1764
1765       declare
1766          EA : constant Element_Access :=
1767                 Container.Elements.EA (Container.Last);
1768
1769       begin
1770          if EA = null then
1771             raise Constraint_Error with "last element is empty";
1772          end if;
1773
1774          return EA.all;
1775       end;
1776    end Last_Element;
1777
1778    ----------------
1779    -- Last_Index --
1780    ----------------
1781
1782    function Last_Index (Container : Vector) return Extended_Index is
1783    begin
1784       return Container.Last;
1785    end Last_Index;
1786
1787    ------------
1788    -- Length --
1789    ------------
1790
1791    function Length (Container : Vector) return Count_Type is
1792       L : constant Int := Int (Container.Last);
1793       F : constant Int := Int (Index_Type'First);
1794       N : constant Int'Base := L - F + 1;
1795
1796    begin
1797       return Count_Type (N);
1798    end Length;
1799
1800    ----------
1801    -- Move --
1802    ----------
1803
1804    procedure Move
1805      (Target : in out Vector;
1806       Source : in out Vector)
1807    is
1808    begin
1809       if Target'Address = Source'Address then
1810          return;
1811       end if;
1812
1813       if Source.Busy > 0 then
1814          raise Program_Error with
1815            "attempt to tamper with elements (Source is busy)";
1816       end if;
1817
1818       Clear (Target);  --  Checks busy-bit
1819
1820       declare
1821          Target_Elements : constant Elements_Access := Target.Elements;
1822       begin
1823          Target.Elements := Source.Elements;
1824          Source.Elements := Target_Elements;
1825       end;
1826
1827       Target.Last := Source.Last;
1828       Source.Last := No_Index;
1829    end Move;
1830
1831    ----------
1832    -- Next --
1833    ----------
1834
1835    function Next (Position : Cursor) return Cursor is
1836    begin
1837       if Position.Container = null then
1838          return No_Element;
1839       end if;
1840
1841       if Position.Index < Position.Container.Last then
1842          return (Position.Container, Position.Index + 1);
1843       end if;
1844
1845       return No_Element;
1846    end Next;
1847
1848    ----------
1849    -- Next --
1850    ----------
1851
1852    procedure Next (Position : in out Cursor) is
1853    begin
1854       if Position.Container = null then
1855          return;
1856       end if;
1857
1858       if Position.Index < Position.Container.Last then
1859          Position.Index := Position.Index + 1;
1860       else
1861          Position := No_Element;
1862       end if;
1863    end Next;
1864
1865    -------------
1866    -- Prepend --
1867    -------------
1868
1869    procedure Prepend (Container : in out Vector; New_Item : Vector) is
1870    begin
1871       Insert (Container, Index_Type'First, New_Item);
1872    end Prepend;
1873
1874    procedure Prepend
1875      (Container : in out Vector;
1876       New_Item  : Element_Type;
1877       Count     : Count_Type := 1)
1878    is
1879    begin
1880       Insert (Container,
1881               Index_Type'First,
1882               New_Item,
1883               Count);
1884    end Prepend;
1885
1886    --------------
1887    -- Previous --
1888    --------------
1889
1890    procedure Previous (Position : in out Cursor) is
1891    begin
1892       if Position.Container = null then
1893          return;
1894       end if;
1895
1896       if Position.Index > Index_Type'First then
1897          Position.Index := Position.Index - 1;
1898       else
1899          Position := No_Element;
1900       end if;
1901    end Previous;
1902
1903    function Previous (Position : Cursor) return Cursor is
1904    begin
1905       if Position.Container = null then
1906          return No_Element;
1907       end if;
1908
1909       if Position.Index > Index_Type'First then
1910          return (Position.Container, Position.Index - 1);
1911       end if;
1912
1913       return No_Element;
1914    end Previous;
1915
1916    -------------------
1917    -- Query_Element --
1918    -------------------
1919
1920    procedure Query_Element
1921      (Container : Vector;
1922       Index     : Index_Type;
1923       Process   : not null access procedure (Element : Element_Type))
1924    is
1925       V : Vector renames Container'Unrestricted_Access.all;
1926       B : Natural renames V.Busy;
1927       L : Natural renames V.Lock;
1928
1929    begin
1930       if Index > Container.Last then
1931          raise Constraint_Error with "Index is out of range";
1932       end if;
1933
1934       if V.Elements.EA (Index) = null then
1935          raise Constraint_Error with "element is null";
1936       end if;
1937
1938       B := B + 1;
1939       L := L + 1;
1940
1941       begin
1942          Process (V.Elements.EA (Index).all);
1943       exception
1944          when others =>
1945             L := L - 1;
1946             B := B - 1;
1947             raise;
1948       end;
1949
1950       L := L - 1;
1951       B := B - 1;
1952    end Query_Element;
1953
1954    procedure Query_Element
1955      (Position : Cursor;
1956       Process  : not null access procedure (Element : Element_Type))
1957    is
1958    begin
1959       if Position.Container = null then
1960          raise Constraint_Error with "Position cursor has no element";
1961       end if;
1962
1963       Query_Element (Position.Container.all, Position.Index, Process);
1964    end Query_Element;
1965
1966    ----------
1967    -- Read --
1968    ----------
1969
1970    procedure Read
1971      (Stream    : not null access Root_Stream_Type'Class;
1972       Container : out Vector)
1973    is
1974       Length : Count_Type'Base;
1975       Last   : Index_Type'Base := Index_Type'Pred (Index_Type'First);
1976
1977       B : Boolean;
1978
1979    begin
1980       Clear (Container);
1981
1982       Count_Type'Base'Read (Stream, Length);
1983
1984       if Length > Capacity (Container) then
1985          Reserve_Capacity (Container, Capacity => Length);
1986       end if;
1987
1988       for J in Count_Type range 1 .. Length loop
1989          Last := Last + 1;
1990
1991          Boolean'Read (Stream, B);
1992
1993          if B then
1994             Container.Elements.EA (Last) :=
1995               new Element_Type'(Element_Type'Input (Stream));
1996          end if;
1997
1998          Container.Last := Last;
1999       end loop;
2000    end Read;
2001
2002    procedure Read
2003      (Stream   : not null access Root_Stream_Type'Class;
2004       Position : out Cursor)
2005    is
2006    begin
2007       raise Program_Error with "attempt to stream vector cursor";
2008    end Read;
2009
2010    ---------------------
2011    -- Replace_Element --
2012    ---------------------
2013
2014    procedure Replace_Element
2015      (Container : in out Vector;
2016       Index     : Index_Type;
2017       New_Item  : Element_Type)
2018    is
2019    begin
2020       if Index > Container.Last then
2021          raise Constraint_Error with "Index is out of range";
2022       end if;
2023
2024       if Container.Lock > 0 then
2025          raise Program_Error with
2026            "attempt to tamper with cursors (vector is locked)";
2027       end if;
2028
2029       declare
2030          X : Element_Access := Container.Elements.EA (Index);
2031       begin
2032          Container.Elements.EA (Index) := new Element_Type'(New_Item);
2033          Free (X);
2034       end;
2035    end Replace_Element;
2036
2037    procedure Replace_Element
2038      (Container : in out Vector;
2039       Position  : Cursor;
2040       New_Item  : Element_Type)
2041    is
2042    begin
2043       if Position.Container = null then
2044          raise Constraint_Error with "Position cursor has no element";
2045       end if;
2046
2047       if Position.Container /= Container'Unrestricted_Access then
2048          raise Program_Error with "Position cursor denotes wrong container";
2049       end if;
2050
2051       if Position.Index > Container.Last then
2052          raise Constraint_Error with "Position cursor is out of range";
2053       end if;
2054
2055       if Container.Lock > 0 then
2056          raise Program_Error with
2057            "attempt to tamper with cursors (vector is locked)";
2058       end if;
2059
2060       declare
2061          X : Element_Access := Container.Elements.EA (Position.Index);
2062       begin
2063          Container.Elements.EA (Position.Index) := new Element_Type'(New_Item);
2064          Free (X);
2065       end;
2066    end Replace_Element;
2067
2068    ----------------------
2069    -- Reserve_Capacity --
2070    ----------------------
2071
2072    procedure Reserve_Capacity
2073      (Container : in out Vector;
2074       Capacity  : Count_Type)
2075    is
2076       N : constant Count_Type := Length (Container);
2077
2078    begin
2079       if Capacity = 0 then
2080          if N = 0 then
2081             declare
2082                X : Elements_Access := Container.Elements;
2083             begin
2084                Container.Elements := null;
2085                Free (X);
2086             end;
2087
2088          elsif N < Container.Elements.EA'Length then
2089             if Container.Busy > 0 then
2090                raise Program_Error with
2091                  "attempt to tamper with elements (vector is busy)";
2092             end if;
2093
2094             declare
2095                subtype Array_Index_Subtype is Index_Type'Base range
2096                  Index_Type'First .. Container.Last;
2097
2098                Src : Elements_Array renames
2099                        Container.Elements.EA (Array_Index_Subtype);
2100
2101                X : Elements_Access := Container.Elements;
2102
2103             begin
2104                Container.Elements := new Elements_Type'(Container.Last, Src);
2105                Free (X);
2106             end;
2107          end if;
2108
2109          return;
2110       end if;
2111
2112       if Container.Elements = null then
2113          declare
2114             Last_As_Int : constant Int'Base :=
2115                             Int (Index_Type'First) + Int (Capacity) - 1;
2116
2117          begin
2118             if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2119                raise Constraint_Error with "new length is out of range";
2120             end if;
2121
2122             declare
2123                Last : constant Index_Type := Index_Type (Last_As_Int);
2124
2125             begin
2126                Container.Elements := new Elements_Type (Last);
2127             end;
2128          end;
2129
2130          return;
2131       end if;
2132
2133       if Capacity <= N then
2134          if N < Container.Elements.EA'Length then
2135             if Container.Busy > 0 then
2136                raise Program_Error with
2137                  "attempt to tamper with elements (vector is busy)";
2138             end if;
2139
2140             declare
2141                subtype Array_Index_Subtype is Index_Type'Base range
2142                  Index_Type'First .. Container.Last;
2143
2144                Src : Elements_Array renames
2145                        Container.Elements.EA (Array_Index_Subtype);
2146
2147                X : Elements_Access := Container.Elements;
2148
2149             begin
2150                Container.Elements := new Elements_Type'(Container.Last, Src);
2151                Free (X);
2152             end;
2153          end if;
2154
2155          return;
2156       end if;
2157
2158       if Capacity = Container.Elements.EA'Length then
2159          return;
2160       end if;
2161
2162       if Container.Busy > 0 then
2163          raise Program_Error with
2164            "attempt to tamper with elements (vector is busy)";
2165       end if;
2166
2167       declare
2168          Last_As_Int : constant Int'Base :=
2169                          Int (Index_Type'First) + Int (Capacity) - 1;
2170
2171       begin
2172          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2173             raise Constraint_Error with "new length is out of range";
2174          end if;
2175
2176          declare
2177             Last : constant Index_Type := Index_Type (Last_As_Int);
2178             X    : Elements_Access := Container.Elements;
2179
2180             subtype Index_Subtype is Index_Type'Base range
2181               Index_Type'First .. Container.Last;
2182
2183          begin
2184             Container.Elements := new Elements_Type (Last);
2185
2186             declare
2187                Src : Elements_Array renames
2188                        X.EA (Index_Subtype);
2189
2190                Tgt : Elements_Array renames
2191                        Container.Elements.EA (Index_Subtype);
2192
2193             begin
2194                Tgt := Src;
2195             end;
2196
2197             Free (X);
2198          end;
2199       end;
2200    end Reserve_Capacity;
2201
2202    ----------------------
2203    -- Reverse_Elements --
2204    ----------------------
2205
2206    procedure Reverse_Elements (Container : in out Vector) is
2207    begin
2208       if Container.Length <= 1 then
2209          return;
2210       end if;
2211
2212       if Container.Lock > 0 then
2213          raise Program_Error with
2214            "attempt to tamper with cursors (vector is locked)";
2215       end if;
2216
2217       declare
2218          I : Index_Type;
2219          J : Index_Type;
2220          E : Elements_Array renames Container.Elements.EA;
2221
2222       begin
2223          I := Index_Type'First;
2224          J := Container.Last;
2225          while I < J loop
2226             declare
2227                EI : constant Element_Access := E (I);
2228
2229             begin
2230                E (I) := E (J);
2231                E (J) := EI;
2232             end;
2233
2234             I := I + 1;
2235             J := J - 1;
2236          end loop;
2237       end;
2238    end Reverse_Elements;
2239
2240    ------------------
2241    -- Reverse_Find --
2242    ------------------
2243
2244    function Reverse_Find
2245      (Container : Vector;
2246       Item      : Element_Type;
2247       Position  : Cursor := No_Element) return Cursor
2248    is
2249       Last : Index_Type'Base;
2250
2251    begin
2252       if Position.Container /= null
2253         and then Position.Container /= Container'Unchecked_Access
2254       then
2255          raise Program_Error with "Position cursor denotes wrong container";
2256       end if;
2257
2258       if Position.Container = null
2259         or else Position.Index > Container.Last
2260       then
2261          Last := Container.Last;
2262       else
2263          Last := Position.Index;
2264       end if;
2265
2266       for Indx in reverse Index_Type'First .. Last loop
2267          if Container.Elements.EA (Indx) /= null
2268            and then Container.Elements.EA (Indx).all = Item
2269          then
2270             return (Container'Unchecked_Access, Indx);
2271          end if;
2272       end loop;
2273
2274       return No_Element;
2275    end Reverse_Find;
2276
2277    ------------------------
2278    -- Reverse_Find_Index --
2279    ------------------------
2280
2281    function Reverse_Find_Index
2282      (Container : Vector;
2283       Item      : Element_Type;
2284       Index     : Index_Type := Index_Type'Last) return Extended_Index
2285    is
2286       Last : Index_Type'Base;
2287
2288    begin
2289       if Index > Container.Last then
2290          Last := Container.Last;
2291       else
2292          Last := Index;
2293       end if;
2294
2295       for Indx in reverse Index_Type'First .. Last loop
2296          if Container.Elements.EA (Indx) /= null
2297            and then Container.Elements.EA (Indx).all = Item
2298          then
2299             return Indx;
2300          end if;
2301       end loop;
2302
2303       return No_Index;
2304    end Reverse_Find_Index;
2305
2306    ---------------------
2307    -- Reverse_Iterate --
2308    ---------------------
2309
2310    procedure Reverse_Iterate
2311      (Container : Vector;
2312       Process   : not null access procedure (Position : Cursor))
2313    is
2314       V : Vector renames Container'Unrestricted_Access.all;
2315       B : Natural renames V.Busy;
2316
2317    begin
2318       B := B + 1;
2319
2320       begin
2321          for Indx in reverse Index_Type'First .. Container.Last loop
2322             Process (Cursor'(Container'Unchecked_Access, Indx));
2323          end loop;
2324       exception
2325          when others =>
2326             B := B - 1;
2327             raise;
2328       end;
2329
2330       B := B - 1;
2331    end Reverse_Iterate;
2332
2333    ----------------
2334    -- Set_Length --
2335    ----------------
2336
2337    procedure Set_Length
2338      (Container : in out Vector;
2339       Length    : Count_Type)
2340    is
2341       N : constant Count_Type := Indefinite_Vectors.Length (Container);
2342
2343    begin
2344       if Length = N then
2345          return;
2346       end if;
2347
2348       if Container.Busy > 0 then
2349          raise Program_Error with
2350            "attempt to tamper with elements (vector is busy)";
2351       end if;
2352
2353       if Length < N then
2354          for Index in 1 .. N - Length loop
2355             declare
2356                J : constant Index_Type := Container.Last;
2357                X : Element_Access := Container.Elements.EA (J);
2358
2359             begin
2360                Container.Elements.EA (J) := null;
2361                Container.Last := J - 1;
2362                Free (X);
2363             end;
2364          end loop;
2365
2366          return;
2367       end if;
2368
2369       if Length > Capacity (Container) then
2370          Reserve_Capacity (Container, Capacity => Length);
2371       end if;
2372
2373       declare
2374          Last_As_Int : constant Int'Base :=
2375                          Int (Index_Type'First) + Int (Length) - 1;
2376
2377       begin
2378          Container.Last := Index_Type (Last_As_Int);
2379       end;
2380    end Set_Length;
2381
2382    ----------
2383    -- Swap --
2384    ----------
2385
2386    procedure Swap
2387      (Container : in out Vector;
2388       I, J      : Index_Type)
2389    is
2390    begin
2391       if I > Container.Last then
2392          raise Constraint_Error with "I index is out of range";
2393       end if;
2394
2395       if J > Container.Last then
2396          raise Constraint_Error with "J index is out of range";
2397       end if;
2398
2399       if I = J then
2400          return;
2401       end if;
2402
2403       if Container.Lock > 0 then
2404          raise Program_Error with
2405            "attempt to tamper with cursors (vector is locked)";
2406       end if;
2407
2408       declare
2409          EI : Element_Access renames Container.Elements.EA (I);
2410          EJ : Element_Access renames Container.Elements.EA (J);
2411
2412          EI_Copy : constant Element_Access := EI;
2413
2414       begin
2415          EI := EJ;
2416          EJ := EI_Copy;
2417       end;
2418    end Swap;
2419
2420    procedure Swap
2421      (Container : in out Vector;
2422       I, J      : Cursor)
2423    is
2424    begin
2425       if I.Container = null then
2426          raise Constraint_Error with "I cursor has no element";
2427       end if;
2428
2429       if J.Container = null then
2430          raise Constraint_Error with "J cursor has no element";
2431       end if;
2432
2433       if I.Container /= Container'Unrestricted_Access then
2434          raise Program_Error with "I cursor denotes wrong container";
2435       end if;
2436
2437       if J.Container /= Container'Unrestricted_Access then
2438          raise Program_Error with "J cursor denotes wrong container";
2439       end if;
2440
2441       Swap (Container, I.Index, J.Index);
2442    end Swap;
2443
2444    ---------------
2445    -- To_Cursor --
2446    ---------------
2447
2448    function To_Cursor
2449      (Container : Vector;
2450       Index     : Extended_Index) return Cursor
2451    is
2452    begin
2453       if Index not in Index_Type'First .. Container.Last then
2454          return No_Element;
2455       end if;
2456
2457       return Cursor'(Container'Unchecked_Access, Index);
2458    end To_Cursor;
2459
2460    --------------
2461    -- To_Index --
2462    --------------
2463
2464    function To_Index (Position : Cursor) return Extended_Index is
2465    begin
2466       if Position.Container = null then
2467          return No_Index;
2468       end if;
2469
2470       if Position.Index <= Position.Container.Last then
2471          return Position.Index;
2472       end if;
2473
2474       return No_Index;
2475    end To_Index;
2476
2477    ---------------
2478    -- To_Vector --
2479    ---------------
2480
2481    function To_Vector (Length : Count_Type) return Vector is
2482    begin
2483       if Length = 0 then
2484          return Empty_Vector;
2485       end if;
2486
2487       declare
2488          First       : constant Int := Int (Index_Type'First);
2489          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2490          Last        : Index_Type;
2491          Elements    : Elements_Access;
2492
2493       begin
2494          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2495             raise Constraint_Error with "Length is out of range";
2496          end if;
2497
2498          Last := Index_Type (Last_As_Int);
2499          Elements := new Elements_Type (Last);
2500
2501          return (Controlled with Elements, Last, 0, 0);
2502       end;
2503    end To_Vector;
2504
2505    function To_Vector
2506      (New_Item : Element_Type;
2507       Length   : Count_Type) return Vector
2508    is
2509    begin
2510       if Length = 0 then
2511          return Empty_Vector;
2512       end if;
2513
2514       declare
2515          First       : constant Int := Int (Index_Type'First);
2516          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2517          Last        : Index_Type'Base;
2518          Elements    : Elements_Access;
2519
2520       begin
2521          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2522             raise Constraint_Error with "Length is out of range";
2523          end if;
2524
2525          Last := Index_Type (Last_As_Int);
2526          Elements := new Elements_Type (Last);
2527
2528          Last := Index_Type'First;
2529
2530          begin
2531             loop
2532                Elements.EA (Last) := new Element_Type'(New_Item);
2533                exit when Last = Elements.Last;
2534                Last := Last + 1;
2535             end loop;
2536
2537          exception
2538             when others =>
2539                for J in Index_Type'First .. Last - 1 loop
2540                   Free (Elements.EA (J));
2541                end loop;
2542
2543                Free (Elements);
2544                raise;
2545          end;
2546
2547          return (Controlled with Elements, Last, 0, 0);
2548       end;
2549    end To_Vector;
2550
2551    --------------------
2552    -- Update_Element --
2553    --------------------
2554
2555    procedure Update_Element
2556      (Container : in out Vector;
2557       Index     : Index_Type;
2558       Process   : not null access procedure (Element : in out Element_Type))
2559    is
2560       B : Natural renames Container.Busy;
2561       L : Natural renames Container.Lock;
2562
2563    begin
2564       if Index > Container.Last then
2565          raise Constraint_Error with "Index is out of range";
2566       end if;
2567
2568       if Container.Elements.EA (Index) = null then
2569          raise Constraint_Error with "element is null";
2570       end if;
2571
2572       B := B + 1;
2573       L := L + 1;
2574
2575       begin
2576          Process (Container.Elements.EA (Index).all);
2577       exception
2578          when others =>
2579             L := L - 1;
2580             B := B - 1;
2581             raise;
2582       end;
2583
2584       L := L - 1;
2585       B := B - 1;
2586    end Update_Element;
2587
2588    procedure Update_Element
2589      (Container : in out Vector;
2590       Position  : Cursor;
2591       Process   : not null access procedure (Element : in out Element_Type))
2592    is
2593    begin
2594       if Position.Container = null then
2595          raise Constraint_Error with "Position cursor has no element";
2596       end if;
2597
2598       if Position.Container /= Container'Unrestricted_Access then
2599          raise Program_Error with "Position cursor denotes wrong container";
2600       end if;
2601
2602       Update_Element (Container, Position.Index, Process);
2603    end Update_Element;
2604
2605    -----------
2606    -- Write --
2607    -----------
2608
2609    procedure Write
2610      (Stream    : not null access Root_Stream_Type'Class;
2611       Container : Vector)
2612    is
2613       N : constant Count_Type := Length (Container);
2614
2615    begin
2616       Count_Type'Base'Write (Stream, N);
2617
2618       if N = 0 then
2619          return;
2620       end if;
2621
2622       declare
2623          E : Elements_Array renames Container.Elements.EA;
2624
2625       begin
2626          for Indx in Index_Type'First .. Container.Last loop
2627             if E (Indx) = null then
2628                Boolean'Write (Stream, False);
2629             else
2630                Boolean'Write (Stream, True);
2631                Element_Type'Output (Stream, E (Indx).all);
2632             end if;
2633          end loop;
2634       end;
2635    end Write;
2636
2637    procedure Write
2638      (Stream   : not null access Root_Stream_Type'Class;
2639       Position : Cursor)
2640    is
2641    begin
2642       raise Program_Error with "attempt to stream vector cursor";
2643    end Write;
2644
2645 end Ada.Containers.Indefinite_Vectors;