gcc/ada/a-coinve.adb

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