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-2005 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    -- Assign --
 480    ------------
 481
 482    procedure Assign
 483      (Target : in out Vector;
 484       Source : Vector)
 485    is
 486       N : constant Count_Type := Length (Source);
 487
 488    begin
 489       if Target'Address = Source'Address then
 490          return;
 491       end if;
 492
 493       Clear (Target);
 494
 495       if N = 0 then
 496          return;
 497       end if;
 498
 499       if N > Capacity (Target) then
 500          Reserve_Capacity (Target, Capacity => N);
 501       end if;
 502
 503       for J in Index_Type'First .. Source.Last loop
 504          declare
 505             EA : constant Element_Access := Source.Elements (J);
 506          begin
 507             if EA /= null then
 508                Target.Elements (J) := new Element_Type'(EA.all);
 509             end if;
 510          end;
 511
 512          Target.Last := J;
 513       end loop;
 514    end Assign;
 515
 516    --------------
 517    -- Capacity --
 518    --------------
 519
 520    function Capacity (Container : Vector) return Count_Type is
 521    begin
 522       if Container.Elements = null then
 523          return 0;
 524       end if;
 525
 526       return Container.Elements'Length;
 527    end Capacity;
 528
 529    -----------
 530    -- Clear --
 531    -----------
 532
 533    procedure Clear (Container : in out Vector) is
 534    begin
 535       if Container.Busy > 0 then
 536          raise Program_Error;
 537       end if;
 538
 539       while Container.Last >= Index_Type'First loop
 540          declare
 541             X : Element_Access := Container.Elements (Container.Last);
 542          begin
 543             Container.Elements (Container.Last) := null;
 544             Container.Last := Container.Last - 1;
 545             Free (X);
 546          end;
 547       end loop;
 548    end Clear;
 549
 550    --------------
 551    -- Contains --
 552    --------------
 553
 554    function Contains
 555      (Container : Vector;
 556       Item      : Element_Type) return Boolean is
 557    begin
 558       return Find_Index (Container, Item) /= No_Index;
 559    end Contains;
 560
 561    ------------
 562    -- Delete --
 563    ------------
 564
 565    procedure Delete
 566      (Container : in out Vector;
 567       Index     : Extended_Index;
 568       Count     : Count_Type := 1)
 569    is
 570    begin
 571       if Index < Index_Type'First then
 572          raise Constraint_Error;
 573       end if;
 574
 575       if Index > Container.Last then
 576          if Index > Container.Last + 1 then
 577             raise Constraint_Error;
 578          end if;
 579
 580          return;
 581       end if;
 582
 583       if Count = 0 then
 584          return;
 585       end if;
 586
 587       if Container.Busy > 0 then
 588          raise Program_Error;
 589       end if;
 590
 591       declare
 592          Index_As_Int    : constant Int := Int (Index);
 593          Old_Last_As_Int : constant Int := Int (Container.Last);
 594
 595          --  TODO: somewhat vestigial...fix ???
 596          Count1 : constant Int'Base := Int (Count);
 597          Count2 : constant Int'Base := Old_Last_As_Int - Index_As_Int + 1;
 598          N      : constant Int'Base := Int'Min (Count1, Count2);
 599
 600          J_As_Int : constant Int'Base := Index_As_Int + N;
 601          E        : Elements_Type renames Container.Elements.all;
 602
 603       begin
 604          if J_As_Int > Old_Last_As_Int then
 605             while Container.Last >= Index loop
 606                declare
 607                   K : constant Index_Type := Container.Last;
 608                   X : Element_Access := E (K);
 609
 610                begin
 611                   E (K) := null;
 612                   Container.Last := K - 1;
 613                   Free (X);
 614                end;
 615             end loop;
 616
 617          else
 618             declare
 619                J : constant Index_Type := Index_Type (J_As_Int);
 620
 621                New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
 622                New_Last        : constant Index_Type :=
 623                                    Index_Type (New_Last_As_Int);
 624
 625             begin
 626                for K in Index .. J - 1 loop
 627                   declare
 628                      X : Element_Access := E (K);
 629                   begin
 630                      E (K) := null;
 631                      Free (X);
 632                   end;
 633                end loop;
 634
 635                E (Index .. New_Last) := E (J .. Container.Last);
 636                Container.Last := New_Last;
 637             end;
 638          end if;
 639       end;
 640    end Delete;
 641
 642    procedure Delete
 643      (Container : in out Vector;
 644       Position  : in out Cursor;
 645       Count     : Count_Type := 1)
 646    is
 647    begin
 648       if Position.Container = null then
 649          raise Constraint_Error;
 650       end if;
 651
 652       if Position.Container /=
 653            Vector_Access'(Container'Unchecked_Access)
 654         or else Position.Index > Container.Last
 655       then
 656          raise Program_Error;
 657       end if;
 658
 659       Delete (Container, Position.Index, Count);
 660
 661       if Position.Index <= Container.Last then
 662          Position := (Container'Unchecked_Access, Position.Index);
 663       else
 664          Position := No_Element;
 665       end if;
 666    end Delete;
 667
 668    ------------------
 669    -- Delete_First --
 670    ------------------
 671
 672    procedure Delete_First
 673      (Container : in out Vector;
 674       Count     : Count_Type := 1)
 675    is
 676    begin
 677       if Count = 0 then
 678          return;
 679       end if;
 680
 681       if Count >= Length (Container) then
 682          Clear (Container);
 683          return;
 684       end if;
 685
 686       Delete (Container, Index_Type'First, Count);
 687    end Delete_First;
 688
 689    -----------------
 690    -- Delete_Last --
 691    -----------------
 692
 693    procedure Delete_Last
 694      (Container : in out Vector;
 695       Count     : Count_Type := 1)
 696    is
 697       N : constant Count_Type := Length (Container);
 698
 699    begin
 700       if Count = 0
 701         or else N = 0
 702       then
 703          return;
 704       end if;
 705
 706       if Container.Busy > 0 then
 707          raise Program_Error;
 708       end if;
 709
 710       declare
 711          E : Elements_Type renames Container.Elements.all;
 712
 713       begin
 714          for Indx in 1 .. Count_Type'Min (Count, N) loop
 715             declare
 716                J : constant Index_Type := Container.Last;
 717                X : Element_Access := E (J);
 718
 719             begin
 720                E (J) := null;
 721                Container.Last := J - 1;
 722                Free (X);
 723             end;
 724          end loop;
 725       end;
 726    end Delete_Last;
 727
 728    -------------
 729    -- Element --
 730    -------------
 731
 732    function Element
 733      (Container : Vector;
 734       Index     : Index_Type) return Element_Type
 735    is
 736    begin
 737       if Index > Container.Last then
 738          raise Constraint_Error;
 739       end if;
 740
 741       return Container.Elements (Index).all;
 742    end Element;
 743
 744    function Element (Position : Cursor) return Element_Type is
 745    begin
 746       if Position.Container = null then
 747          raise Constraint_Error;
 748       end if;
 749
 750       return Element (Position.Container.all, Position.Index);
 751    end Element;
 752
 753    --------------
 754    -- Finalize --
 755    --------------
 756
 757    procedure Finalize (Container : in out Vector) is
 758    begin
 759       Clear (Container);
 760
 761       declare
 762          X : Elements_Access := Container.Elements;
 763       begin
 764          Container.Elements := null;
 765          Free (X);
 766       end;
 767    end Finalize;
 768
 769    ----------
 770    -- Find --
 771    ----------
 772
 773    function Find
 774      (Container : Vector;
 775       Item      : Element_Type;
 776       Position  : Cursor := No_Element) return Cursor is
 777
 778    begin
 779       if Position.Container /= null
 780         and then (Position.Container /=
 781                     Vector_Access'(Container'Unchecked_Access)
 782                   or else Position.Index > Container.Last)
 783       then
 784          raise Program_Error;
 785       end if;
 786
 787       for J in Position.Index .. Container.Last loop
 788          if Container.Elements (J) /= null
 789            and then Container.Elements (J).all = Item
 790          then
 791             return (Container'Unchecked_Access, J);
 792          end if;
 793       end loop;
 794
 795       return No_Element;
 796    end Find;
 797
 798    ----------------
 799    -- Find_Index --
 800    ----------------
 801
 802    function Find_Index
 803      (Container : Vector;
 804       Item      : Element_Type;
 805       Index     : Index_Type := Index_Type'First) return Extended_Index is
 806    begin
 807       for Indx in Index .. Container.Last loop
 808          if Container.Elements (Indx) /= null
 809            and then Container.Elements (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       return Element (Container, Index_Type'First);
 838    end First_Element;
 839
 840    -----------------
 841    -- First_Index --
 842    -----------------
 843
 844    function First_Index (Container : Vector) return Index_Type is
 845       pragma Unreferenced (Container);
 846    begin
 847       return Index_Type'First;
 848    end First_Index;
 849
 850    ---------------------
 851    -- Generic_Sorting --
 852    ---------------------
 853
 854    package body Generic_Sorting is
 855
 856       -----------------------
 857       -- Local Subprograms --
 858       -----------------------
 859
 860       function Is_Less (L, R : Element_Access) return Boolean;
 861       pragma Inline (Is_Less);
 862
 863       -------------
 864       -- Is_Less --
 865       -------------
 866
 867       function Is_Less (L, R : Element_Access) return Boolean is
 868       begin
 869          if L = null then
 870             return R /= null;
 871          elsif R = null then
 872             return False;
 873          else
 874             return L.all < R.all;
 875          end if;
 876       end Is_Less;
 877
 878       ---------------
 879       -- Is_Sorted --
 880       ---------------
 881
 882       function Is_Sorted (Container : Vector) return Boolean is
 883       begin
 884          if Container.Last <= Index_Type'First then
 885             return True;
 886          end if;
 887
 888          declare
 889             E : Elements_Type renames Container.Elements.all;
 890          begin
 891             for I in Index_Type'First .. Container.Last - 1 loop
 892                if Is_Less (E (I + 1), E (I)) then
 893                   return False;
 894                end if;
 895             end loop;
 896          end;
 897
 898          return True;
 899       end Is_Sorted;
 900
 901       -----------
 902       -- Merge --
 903       -----------
 904
 905       procedure Merge (Target, Source : in out Vector) is
 906          I : Index_Type'Base := Target.Last;
 907          J : Index_Type'Base;
 908
 909       begin
 910          if Target.Last < Index_Type'First then
 911             Move (Target => Target, Source => Source);
 912             return;
 913          end if;
 914
 915          if Target'Address = Source'Address then
 916             return;
 917          end if;
 918
 919          if Source.Last < Index_Type'First then
 920             return;
 921          end if;
 922
 923          if Source.Busy > 0 then
 924             raise Program_Error;
 925          end if;
 926
 927          Target.Set_Length (Length (Target) + Length (Source));
 928
 929          J := Target.Last;
 930          while Source.Last >= Index_Type'First loop
 931             if I < Index_Type'First then
 932                declare
 933                   Src : Elements_Type renames
 934                     Source.Elements (Index_Type'First .. Source.Last);
 935
 936                begin
 937                   Target.Elements (Index_Type'First .. J) := Src;
 938                   Src := (others => null);
 939                end;
 940
 941                Source.Last := No_Index;
 942                return;
 943             end if;
 944
 945             declare
 946                Src : Element_Access renames Source.Elements (Source.Last);
 947                Tgt : Element_Access renames Target.Elements (I);
 948
 949             begin
 950                if Is_Less (Src, Tgt) then
 951                   Target.Elements (J) := Tgt;
 952                   Tgt := null;
 953                   I := I - 1;
 954
 955                else
 956                   Target.Elements (J) := Src;
 957                   Src := null;
 958                   Source.Last := Source.Last - 1;
 959                end if;
 960             end;
 961
 962             J := J - 1;
 963          end loop;
 964       end Merge;
 965
 966       ----------
 967       -- Sort --
 968       ----------
 969
 970       procedure Sort (Container : in out Vector)
 971       is
 972          procedure Sort is
 973             new Generic_Array_Sort
 974              (Index_Type   => Index_Type,
 975               Element_Type => Element_Access,
 976               Array_Type   => Elements_Type,
 977               "<"          => Is_Less);
 978
 979       --  Start of processing for Sort
 980
 981       begin
 982          if Container.Last <= Index_Type'First then
 983             return;
 984          end if;
 985
 986          if Container.Lock > 0 then
 987             raise Program_Error;
 988          end if;
 989
 990          Sort (Container.Elements (Index_Type'First .. Container.Last));
 991       end Sort;
 992
 993    end Generic_Sorting;
 994
 995    -----------------
 996    -- Has_Element --
 997    -----------------
 998
 999    function Has_Element (Position : Cursor) return Boolean is
1000    begin
1001       if Position.Container = null then
1002          return False;
1003       end if;
1004
1005       return Position.Index <= Position.Container.Last;
1006    end Has_Element;
1007
1008    ------------
1009    -- Insert --
1010    ------------
1011
1012    procedure Insert
1013      (Container : in out Vector;
1014       Before    : Extended_Index;
1015       New_Item  : Element_Type;
1016       Count     : Count_Type := 1)
1017    is
1018       N : constant Int := Int (Count);
1019
1020       New_Last_As_Int : Int'Base;
1021       New_Last        : Index_Type;
1022
1023       Dst : Elements_Access;
1024
1025    begin
1026       if Before < Index_Type'First then
1027          raise Constraint_Error;
1028       end if;
1029
1030       if Before > Container.Last
1031         and then Before > Container.Last + 1
1032       then
1033          raise Constraint_Error;
1034       end if;
1035
1036       if Count = 0 then
1037          return;
1038       end if;
1039
1040       declare
1041          Old_Last_As_Int : constant Int := Int (Container.Last);
1042
1043       begin
1044          New_Last_As_Int := Old_Last_As_Int + N;
1045
1046          if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1047             raise Constraint_Error;
1048          end if;
1049
1050          New_Last := Index_Type (New_Last_As_Int);
1051       end;
1052
1053       if Container.Busy > 0 then
1054          raise Program_Error;
1055       end if;
1056
1057       if Container.Elements = null then
1058          Container.Elements :=
1059            new Elements_Type (Index_Type'First .. New_Last);
1060
1061          Container.Last := No_Index;
1062
1063          for J in Container.Elements'Range loop
1064             Container.Elements (J) := new Element_Type'(New_Item);
1065             Container.Last := J;
1066          end loop;
1067
1068          return;
1069       end if;
1070
1071       if New_Last <= Container.Elements'Last then
1072          declare
1073             E : Elements_Type renames Container.Elements.all;
1074          begin
1075             if Before <= Container.Last then
1076                declare
1077                   Index_As_Int : constant Int'Base :=
1078                                    Index_Type'Pos (Before) + N;
1079
1080                   Index : constant Index_Type := Index_Type (Index_As_Int);
1081
1082                   J : Index_Type'Base := Before;
1083
1084                begin
1085                   E (Index .. New_Last) := E (Before .. Container.Last);
1086                   Container.Last := New_Last;
1087
1088                   while J < Index loop
1089                      E (J) := new Element_Type'(New_Item);
1090                      J := J + 1;
1091                   end loop;
1092                exception
1093                   when others =>
1094                      E (J .. Index - 1) := (others => null);
1095                      raise;
1096                end;
1097
1098             else
1099                for J in Before .. New_Last loop
1100                   E (J) := new Element_Type'(New_Item);
1101                   Container.Last := J;
1102                end loop;
1103             end if;
1104          end;
1105
1106          return;
1107       end if;
1108
1109       declare
1110          First    : constant Int := Int (Index_Type'First);
1111          New_Size : constant Int'Base := New_Last_As_Int - First + 1;
1112          Size     : Int'Base := Int'Max (1, Container.Elements'Length);
1113
1114       begin
1115          while Size < New_Size loop
1116             if Size > Int'Last / 2 then
1117                Size := Int'Last;
1118                exit;
1119             end if;
1120
1121             Size := 2 * Size;
1122          end loop;
1123
1124          --  TODO: The following calculations aren't quite right, since
1125          --  there will be overflow if Index_Type'Range is very large
1126          --  (e.g. this package is instantiated with a 64-bit integer).
1127          --  END TODO.
1128
1129          declare
1130             Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1;
1131          begin
1132             if Size > Max_Size then
1133                Size := Max_Size;
1134             end if;
1135          end;
1136
1137          declare
1138             Dst_Last : constant Index_Type := Index_Type (First + Size - 1);
1139          begin
1140             Dst := new Elements_Type (Index_Type'First .. Dst_Last);
1141          end;
1142       end;
1143
1144       if Before <= Container.Last then
1145          declare
1146             Index_As_Int : constant Int'Base :=
1147                              Index_Type'Pos (Before) + N;
1148
1149             Index : constant Index_Type := Index_Type (Index_As_Int);
1150
1151             Src : Elements_Access := Container.Elements;
1152
1153          begin
1154             Dst (Index_Type'First .. Before - 1) :=
1155               Src (Index_Type'First .. Before - 1);
1156
1157             Dst (Index .. New_Last) := Src (Before .. Container.Last);
1158
1159             Container.Elements := Dst;
1160             Container.Last := New_Last;
1161             Free (Src);
1162
1163             for J in Before .. Index - 1 loop
1164                Dst (J) := new Element_Type'(New_Item);
1165             end loop;
1166          end;
1167
1168       else
1169          declare
1170             Src : Elements_Access := Container.Elements;
1171
1172          begin
1173             Dst (Index_Type'First .. Container.Last) :=
1174               Src (Index_Type'First .. Container.Last);
1175
1176             Container.Elements := Dst;
1177             Free (Src);
1178
1179             for J in Before .. New_Last loop
1180                Dst (J) := new Element_Type'(New_Item);
1181                Container.Last := J;
1182             end loop;
1183          end;
1184       end if;
1185    end Insert;
1186
1187    procedure Insert
1188      (Container : in out Vector;
1189       Before    : Extended_Index;
1190       New_Item  : Vector)
1191    is
1192       N : constant Count_Type := Length (New_Item);
1193
1194    begin
1195       if Before < Index_Type'First then
1196          raise Constraint_Error;
1197       end if;
1198
1199       if Before > Container.Last
1200         and then Before > Container.Last + 1
1201       then
1202          raise Constraint_Error;
1203       end if;
1204
1205       if N = 0 then
1206          return;
1207       end if;
1208
1209       Insert_Space (Container, Before, Count => N);
1210
1211       declare
1212          Dst_Last_As_Int : constant Int'Base :=
1213                              Int'Base (Before) + Int'Base (N) - 1;
1214
1215          Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
1216
1217          Dst : Elements_Type renames
1218                  Container.Elements (Before .. Dst_Last);
1219
1220          Dst_Index : Index_Type'Base := Before - 1;
1221
1222       begin
1223          if Container'Address /= New_Item'Address then
1224             declare
1225                Src : Elements_Type renames
1226                        New_Item.Elements (Index_Type'First .. New_Item.Last);
1227
1228             begin
1229                for Src_Index in Src'Range loop
1230                   Dst_Index := Dst_Index + 1;
1231
1232                   if Src (Src_Index) /= null then
1233                      Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1234                   end if;
1235                end loop;
1236             end;
1237
1238             return;
1239          end if;
1240
1241          declare
1242             subtype Src_Index_Subtype is Index_Type'Base range
1243               Index_Type'First .. Before - 1;
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
1258          if Dst_Last = Container.Last then
1259             return;
1260          end if;
1261
1262          declare
1263             subtype Src_Index_Subtype is Index_Type'Base range
1264               Dst_Last + 1 .. Container.Last;
1265
1266             Src : Elements_Type renames
1267                     Container.Elements (Src_Index_Subtype);
1268
1269          begin
1270             for Src_Index in Src'Range loop
1271                Dst_Index := Dst_Index + 1;
1272
1273                if Src (Src_Index) /= null then
1274                   Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1275                end if;
1276             end loop;
1277          end;
1278       end;
1279    end Insert;
1280
1281    procedure Insert
1282      (Container : in out Vector;
1283       Before    : Cursor;
1284       New_Item  : Vector)
1285    is
1286       Index : Index_Type'Base;
1287
1288    begin
1289       if Before.Container /= null
1290         and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1291       then
1292          raise Program_Error;
1293       end if;
1294
1295       if Is_Empty (New_Item) then
1296          return;
1297       end if;
1298
1299       if Before.Container = null
1300         or else Before.Index > Container.Last
1301       then
1302          if Container.Last = Index_Type'Last then
1303             raise Constraint_Error;
1304          end if;
1305
1306          Index := Container.Last + 1;
1307
1308       else
1309          Index := Before.Index;
1310       end if;
1311
1312       Insert (Container, Index, New_Item);
1313    end Insert;
1314
1315    procedure Insert
1316      (Container : in out Vector;
1317       Before    : Cursor;
1318       New_Item  : Vector;
1319       Position  : out Cursor)
1320    is
1321       Index : Index_Type'Base;
1322
1323    begin
1324       if Before.Container /= null
1325         and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1326       then
1327          raise Program_Error;
1328       end if;
1329
1330       if Is_Empty (New_Item) then
1331          if Before.Container = null
1332            or else Before.Index > Container.Last
1333          then
1334             Position := No_Element;
1335          else
1336             Position := (Container'Unchecked_Access, Before.Index);
1337          end if;
1338
1339          return;
1340       end if;
1341
1342       if Before.Container = null
1343         or else Before.Index > Container.Last
1344       then
1345          if Container.Last = Index_Type'Last then
1346             raise Constraint_Error;
1347          end if;
1348
1349          Index := Container.Last + 1;
1350
1351       else
1352          Index := Before.Index;
1353       end if;
1354
1355       Insert (Container, Index, New_Item);
1356
1357       Position := Cursor'(Container'Unchecked_Access, Index);
1358    end Insert;
1359
1360    procedure Insert
1361      (Container : in out Vector;
1362       Before    : Cursor;
1363       New_Item  : Element_Type;
1364       Count     : Count_Type := 1)
1365    is
1366       Index : Index_Type'Base;
1367
1368    begin
1369       if Before.Container /= null
1370         and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1371       then
1372          raise Program_Error;
1373       end if;
1374
1375       if Count = 0 then
1376          return;
1377       end if;
1378
1379       if Before.Container = null
1380         or else Before.Index > Container.Last
1381       then
1382          if Container.Last = Index_Type'Last then
1383             raise Constraint_Error;
1384          end if;
1385
1386          Index := Container.Last + 1;
1387
1388       else
1389          Index := Before.Index;
1390       end if;
1391
1392       Insert (Container, Index, New_Item, Count);
1393    end Insert;
1394
1395    procedure Insert
1396      (Container : in out Vector;
1397       Before    : Cursor;
1398       New_Item  : Element_Type;
1399       Position  : out Cursor;
1400       Count     : Count_Type := 1)
1401    is
1402       Index : Index_Type'Base;
1403
1404    begin
1405       if Before.Container /= null
1406         and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1407       then
1408          raise Program_Error;
1409       end if;
1410
1411       if Count = 0 then
1412          if Before.Container = null
1413            or else Before.Index > Container.Last
1414          then
1415             Position := No_Element;
1416          else
1417             Position := (Container'Unchecked_Access, Before.Index);
1418          end if;
1419
1420          return;
1421       end if;
1422
1423       if Before.Container = null
1424         or else Before.Index > Container.Last
1425       then
1426          if Container.Last = Index_Type'Last then
1427             raise Constraint_Error;
1428          end if;
1429
1430          Index := Container.Last + 1;
1431
1432       else
1433          Index := Before.Index;
1434       end if;
1435
1436       Insert (Container, Index, New_Item, Count);
1437
1438       Position := (Container'Unchecked_Access, Index);
1439    end Insert;
1440
1441    ------------------
1442    -- Insert_Space --
1443    ------------------
1444
1445    procedure Insert_Space
1446      (Container : in out Vector;
1447       Before    : Extended_Index;
1448       Count     : Count_Type := 1)
1449    is
1450       N : constant Int := Int (Count);
1451
1452       New_Last_As_Int : Int'Base;
1453       New_Last        : Index_Type;
1454
1455       Dst : Elements_Access;
1456
1457    begin
1458       if Before < Index_Type'First then
1459          raise Constraint_Error;
1460       end if;
1461
1462       if Before > Container.Last
1463         and then Before > Container.Last + 1
1464       then
1465          raise Constraint_Error;
1466       end if;
1467
1468       if Count = 0 then
1469          return;
1470       end if;
1471
1472       declare
1473          Old_Last_As_Int : constant Int := Int (Container.Last);
1474
1475       begin
1476          New_Last_As_Int := Old_Last_As_Int + N;
1477
1478          if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1479             raise Constraint_Error;
1480          end if;
1481
1482          New_Last := Index_Type (New_Last_As_Int);
1483       end;
1484
1485       if Container.Busy > 0 then
1486          raise Program_Error;
1487       end if;
1488
1489       if Container.Elements = null then
1490          Container.Elements :=
1491            new Elements_Type (Index_Type'First .. New_Last);
1492
1493          Container.Last := New_Last;
1494          return;
1495       end if;
1496
1497       if New_Last <= Container.Elements'Last then
1498          declare
1499             E : Elements_Type renames Container.Elements.all;
1500
1501          begin
1502             if Before <= Container.Last then
1503                declare
1504                   Index_As_Int : constant Int'Base :=
1505                                    Index_Type'Pos (Before) + N;
1506
1507                   Index : constant Index_Type := Index_Type (Index_As_Int);
1508
1509                begin
1510                   E (Index .. New_Last) := E (Before .. Container.Last);
1511                   E (Before .. Index - 1) := (others => null);
1512                end;
1513             end if;
1514          end;
1515
1516          Container.Last := New_Last;
1517          return;
1518       end if;
1519
1520       declare
1521          First    : constant Int := Int (Index_Type'First);
1522          New_Size : constant Int'Base := New_Last_As_Int - First + 1;
1523          Size     : Int'Base := Int'Max (1, Container.Elements'Length);
1524
1525       begin
1526          while Size < New_Size loop
1527             if Size > Int'Last / 2 then
1528                Size := Int'Last;
1529                exit;
1530             end if;
1531
1532             Size := 2 * Size;
1533          end loop;
1534
1535          --  TODO: The following calculations aren't quite right, since
1536          --  there will be overflow if Index_Type'Range is very large
1537          --  (e.g. this package is instantiated with a 64-bit integer).
1538          --  END TODO.
1539
1540          declare
1541             Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1;
1542          begin
1543             if Size > Max_Size then
1544                Size := Max_Size;
1545             end if;
1546          end;
1547
1548          declare
1549             Dst_Last : constant Index_Type := Index_Type (First + Size - 1);
1550          begin
1551             Dst := new Elements_Type (Index_Type'First .. Dst_Last);
1552          end;
1553       end;
1554
1555       declare
1556          Src : Elements_Access := Container.Elements;
1557
1558       begin
1559          if Before <= Container.Last then
1560             declare
1561                Index_As_Int : constant Int'Base :=
1562                                 Index_Type'Pos (Before) + N;
1563
1564                Index : constant Index_Type := Index_Type (Index_As_Int);
1565
1566             begin
1567                Dst (Index_Type'First .. Before - 1) :=
1568                  Src (Index_Type'First .. Before - 1);
1569
1570                Dst (Index .. New_Last) := Src (Before .. Container.Last);
1571             end;
1572
1573          else
1574             Dst (Index_Type'First .. Container.Last) :=
1575               Src (Index_Type'First .. Container.Last);
1576          end if;
1577
1578          Container.Elements := Dst;
1579          Container.Last := New_Last;
1580          Free (Src);
1581       end;
1582    end Insert_Space;
1583
1584    procedure Insert_Space
1585      (Container : in out Vector;
1586       Before    : Cursor;
1587       Position  : out Cursor;
1588       Count     : Count_Type := 1)
1589    is
1590       Index : Index_Type'Base;
1591
1592    begin
1593       if Before.Container /= null
1594         and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1595       then
1596          raise Program_Error;
1597       end if;
1598
1599       if Count = 0 then
1600          if Before.Container = null
1601            or else Before.Index > Container.Last
1602          then
1603             Position := No_Element;
1604          else
1605             Position := (Container'Unchecked_Access, Before.Index);
1606          end if;
1607
1608          return;
1609       end if;
1610
1611       if Before.Container = null
1612         or else Before.Index > Container.Last
1613       then
1614          if Container.Last = Index_Type'Last then
1615             raise Constraint_Error;
1616          end if;
1617
1618          Index := Container.Last + 1;
1619
1620       else
1621          Index := Before.Index;
1622       end if;
1623
1624       Insert_Space (Container, Index, Count);
1625
1626       Position := Cursor'(Container'Unchecked_Access, Index);
1627    end Insert_Space;
1628
1629    --------------
1630    -- Is_Empty --
1631    --------------
1632
1633    function Is_Empty (Container : Vector) return Boolean is
1634    begin
1635       return Container.Last < Index_Type'First;
1636    end Is_Empty;
1637
1638    -------------
1639    -- Iterate --
1640    -------------
1641
1642    procedure Iterate
1643      (Container : Vector;
1644       Process   : not null access procedure (Position : in Cursor))
1645    is
1646       V : Vector renames Container'Unrestricted_Access.all;
1647       B : Natural renames V.Busy;
1648
1649    begin
1650       B := B + 1;
1651
1652       begin
1653          for Indx in Index_Type'First .. Container.Last loop
1654             Process (Cursor'(Container'Unchecked_Access, Indx));
1655          end loop;
1656       exception
1657          when others =>
1658             B := B - 1;
1659             raise;
1660       end;
1661
1662       B := B - 1;
1663    end Iterate;
1664
1665    ----------
1666    -- Last --
1667    ----------
1668
1669    function Last (Container : Vector) return Cursor is
1670    begin
1671       if Is_Empty (Container) then
1672          return No_Element;
1673       end if;
1674
1675       return (Container'Unchecked_Access, Container.Last);
1676    end Last;
1677
1678    ------------------
1679    -- Last_Element --
1680    ------------------
1681
1682    function Last_Element (Container : Vector) return Element_Type is
1683    begin
1684       return Element (Container, Container.Last);
1685    end Last_Element;
1686
1687    ----------------
1688    -- Last_Index --
1689    ----------------
1690
1691    function Last_Index (Container : Vector) return Extended_Index is
1692    begin
1693       return Container.Last;
1694    end Last_Index;
1695
1696    ------------
1697    -- Length --
1698    ------------
1699
1700    function Length (Container : Vector) return Count_Type is
1701       L : constant Int := Int (Container.Last);
1702       F : constant Int := Int (Index_Type'First);
1703       N : constant Int'Base := L - F + 1;
1704
1705    begin
1706       if N > Count_Type'Pos (Count_Type'Last) then
1707          raise Constraint_Error;
1708       end if;
1709
1710       return Count_Type (N);
1711    end Length;
1712
1713    ----------
1714    -- Move --
1715    ----------
1716
1717    procedure Move
1718      (Target : in out Vector;
1719       Source : in out Vector)
1720    is
1721    begin
1722       if Target'Address = Source'Address then
1723          return;
1724       end if;
1725
1726       if Source.Busy > 0 then
1727          raise Program_Error;
1728       end if;
1729
1730       Clear (Target);
1731
1732       declare
1733          Target_Elements : constant Elements_Access := Target.Elements;
1734       begin
1735          Target.Elements := Source.Elements;
1736          Source.Elements := Target_Elements;
1737       end;
1738
1739       Target.Last := Source.Last;
1740       Source.Last := No_Index;
1741    end Move;
1742
1743    ----------
1744    -- Next --
1745    ----------
1746
1747    function Next (Position : Cursor) return Cursor is
1748    begin
1749       if Position.Container = null then
1750          return No_Element;
1751       end if;
1752
1753       if Position.Index < Position.Container.Last then
1754          return (Position.Container, Position.Index + 1);
1755       end if;
1756
1757       return No_Element;
1758    end Next;
1759
1760    ----------
1761    -- Next --
1762    ----------
1763
1764    procedure Next (Position : in out Cursor) is
1765    begin
1766       if Position.Container = null then
1767          return;
1768       end if;
1769
1770       if Position.Index < Position.Container.Last then
1771          Position.Index := Position.Index + 1;
1772       else
1773          Position := No_Element;
1774       end if;
1775    end Next;
1776
1777    -------------
1778    -- Prepend --
1779    -------------
1780
1781    procedure Prepend (Container : in out Vector; New_Item : Vector) is
1782    begin
1783       Insert (Container, Index_Type'First, New_Item);
1784    end Prepend;
1785
1786    procedure Prepend
1787      (Container : in out Vector;
1788       New_Item  : Element_Type;
1789       Count     : Count_Type := 1)
1790    is
1791    begin
1792       Insert (Container,
1793               Index_Type'First,
1794               New_Item,
1795               Count);
1796    end Prepend;
1797
1798    --------------
1799    -- Previous --
1800    --------------
1801
1802    procedure Previous (Position : in out Cursor) is
1803    begin
1804       if Position.Container = null then
1805          return;
1806       end if;
1807
1808       if Position.Index > Index_Type'First then
1809          Position.Index := Position.Index - 1;
1810       else
1811          Position := No_Element;
1812       end if;
1813    end Previous;
1814
1815    function Previous (Position : Cursor) return Cursor is
1816    begin
1817       if Position.Container = null then
1818          return No_Element;
1819       end if;
1820
1821       if Position.Index > Index_Type'First then
1822          return (Position.Container, Position.Index - 1);
1823       end if;
1824
1825       return No_Element;
1826    end Previous;
1827
1828    -------------------
1829    -- Query_Element --
1830    -------------------
1831
1832    procedure Query_Element
1833      (Container : Vector;
1834       Index     : Index_Type;
1835       Process   : not null access procedure (Element : in Element_Type))
1836    is
1837       V : Vector renames Container'Unrestricted_Access.all;
1838       B : Natural renames V.Busy;
1839       L : Natural renames V.Lock;
1840
1841    begin
1842       if Index > Container.Last then
1843          raise Constraint_Error;
1844       end if;
1845
1846       B := B + 1;
1847       L := L + 1;
1848
1849       begin
1850          Process (V.Elements (Index).all);
1851       exception
1852          when others =>
1853             L := L - 1;
1854             B := B - 1;
1855             raise;
1856       end;
1857
1858       L := L - 1;
1859       B := B - 1;
1860    end Query_Element;
1861
1862    procedure Query_Element
1863      (Position : Cursor;
1864       Process  : not null access procedure (Element : in Element_Type))
1865    is
1866    begin
1867       if Position.Container = null then
1868          raise Constraint_Error;
1869       end if;
1870
1871       Query_Element (Position.Container.all, Position.Index, Process);
1872    end Query_Element;
1873
1874    ----------
1875    -- Read --
1876    ----------
1877
1878    procedure Read
1879      (Stream    : access Root_Stream_Type'Class;
1880       Container : out Vector)
1881    is
1882       Length : Count_Type'Base;
1883       Last   : Index_Type'Base := Index_Type'Pred (Index_Type'First);
1884
1885       B : Boolean;
1886
1887    begin
1888       Clear (Container);
1889
1890       Count_Type'Base'Read (Stream, Length);
1891
1892       if Length > Capacity (Container) then
1893          Reserve_Capacity (Container, Capacity => Length);
1894       end if;
1895
1896       for J in Count_Type range 1 .. Length loop
1897          Last := Last + 1;
1898
1899          Boolean'Read (Stream, B);
1900
1901          if B then
1902             Container.Elements (Last) :=
1903               new Element_Type'(Element_Type'Input (Stream));
1904          end if;
1905
1906          Container.Last := Last;
1907       end loop;
1908    end Read;
1909
1910    ---------------------
1911    -- Replace_Element --
1912    ---------------------
1913
1914    procedure Replace_Element
1915      (Container : Vector;
1916       Index     : Index_Type;
1917       By        : Element_Type)
1918    is
1919    begin
1920       if Index > Container.Last then
1921          raise Constraint_Error;
1922       end if;
1923
1924       if Container.Lock > 0 then
1925          raise Program_Error;
1926       end if;
1927
1928       declare
1929          X : Element_Access := Container.Elements (Index);
1930       begin
1931          Container.Elements (Index) := new Element_Type'(By);
1932          Free (X);
1933       end;
1934    end Replace_Element;
1935
1936    procedure Replace_Element (Position : Cursor; By : Element_Type) is
1937    begin
1938       if Position.Container = null then
1939          raise Constraint_Error;
1940       end if;
1941
1942       Replace_Element (Position.Container.all, Position.Index, By);
1943    end Replace_Element;
1944
1945    ----------------------
1946    -- Reserve_Capacity --
1947    ----------------------
1948
1949    procedure Reserve_Capacity
1950      (Container : in out Vector;
1951       Capacity  : Count_Type)
1952    is
1953       N : constant Count_Type := Length (Container);
1954
1955    begin
1956       if Capacity = 0 then
1957          if N = 0 then
1958             declare
1959                X : Elements_Access := Container.Elements;
1960             begin
1961                Container.Elements := null;
1962                Free (X);
1963             end;
1964
1965          elsif N < Container.Elements'Length then
1966             if Container.Busy > 0 then
1967                raise Program_Error;
1968             end if;
1969
1970             declare
1971                subtype Array_Index_Subtype is Index_Type'Base range
1972                  Index_Type'First .. Container.Last;
1973
1974                Src : Elements_Type renames
1975                        Container.Elements (Array_Index_Subtype);
1976
1977                subtype Array_Subtype is
1978                  Elements_Type (Array_Index_Subtype);
1979
1980                X : Elements_Access := Container.Elements;
1981
1982             begin
1983                Container.Elements := new Array_Subtype'(Src);
1984                Free (X);
1985             end;
1986          end if;
1987
1988          return;
1989       end if;
1990
1991       if Container.Elements = null then
1992          declare
1993             Last_As_Int : constant Int'Base :=
1994                             Int (Index_Type'First) + Int (Capacity) - 1;
1995
1996          begin
1997             if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1998                raise Constraint_Error;
1999             end if;
2000
2001             declare
2002                Last : constant Index_Type := Index_Type (Last_As_Int);
2003
2004                subtype Array_Subtype is
2005                  Elements_Type (Index_Type'First .. Last);
2006
2007             begin
2008                Container.Elements := new Array_Subtype;
2009             end;
2010          end;
2011
2012          return;
2013       end if;
2014
2015       if Capacity <= N then
2016          if N < Container.Elements'Length then
2017             if Container.Busy > 0 then
2018                raise Program_Error;
2019             end if;
2020
2021             declare
2022                subtype Array_Index_Subtype is Index_Type'Base range
2023                  Index_Type'First .. Container.Last;
2024
2025                Src : Elements_Type renames
2026                        Container.Elements (Array_Index_Subtype);
2027
2028                subtype Array_Subtype is
2029                  Elements_Type (Array_Index_Subtype);
2030
2031                X : Elements_Access := Container.Elements;
2032
2033             begin
2034                Container.Elements := new Array_Subtype'(Src);
2035                Free (X);
2036             end;
2037          end if;
2038
2039          return;
2040       end if;
2041
2042       if Capacity = Container.Elements'Length then
2043          return;
2044       end if;
2045
2046       if Container.Busy > 0 then
2047          raise Program_Error;
2048       end if;
2049
2050       declare
2051          Last_As_Int : constant Int'Base :=
2052                          Int (Index_Type'First) + Int (Capacity) - 1;
2053
2054       begin
2055          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2056             raise Constraint_Error;
2057          end if;
2058
2059          declare
2060             Last : constant Index_Type := Index_Type (Last_As_Int);
2061
2062             subtype Array_Subtype is
2063               Elements_Type (Index_Type'First .. Last);
2064
2065             X : Elements_Access := Container.Elements;
2066
2067          begin
2068             Container.Elements := new Array_Subtype;
2069
2070             declare
2071                Src : Elements_Type renames
2072                        X (Index_Type'First .. Container.Last);
2073
2074                Tgt : Elements_Type renames
2075                        Container.Elements (Index_Type'First .. Container.Last);
2076
2077             begin
2078                Tgt := Src;
2079             end;
2080
2081             Free (X);
2082          end;
2083       end;
2084    end Reserve_Capacity;
2085
2086    ------------------
2087    -- Reverse_Find --
2088    ------------------
2089
2090    function Reverse_Find
2091      (Container : Vector;
2092       Item      : Element_Type;
2093       Position  : Cursor := No_Element) return Cursor
2094    is
2095       Last : Index_Type'Base;
2096
2097    begin
2098       if Position.Container /= null
2099         and then Position.Container /=
2100                    Vector_Access'(Container'Unchecked_Access)
2101       then
2102          raise Program_Error;
2103       end if;
2104
2105       if Position.Container = null
2106         or else Position.Index > Container.Last
2107       then
2108          Last := Container.Last;
2109       else
2110          Last := Position.Index;
2111       end if;
2112
2113       for Indx in reverse Index_Type'First .. Last loop
2114          if Container.Elements (Indx) /= null
2115            and then Container.Elements (Indx).all = Item
2116          then
2117             return (Container'Unchecked_Access, Indx);
2118          end if;
2119       end loop;
2120
2121       return No_Element;
2122    end Reverse_Find;
2123
2124    ------------------------
2125    -- Reverse_Find_Index --
2126    ------------------------
2127
2128    function Reverse_Find_Index
2129      (Container : Vector;
2130       Item      : Element_Type;
2131       Index     : Index_Type := Index_Type'Last) return Extended_Index
2132    is
2133       Last : Index_Type'Base;
2134
2135    begin
2136       if Index > Container.Last then
2137          Last := Container.Last;
2138       else
2139          Last := Index;
2140       end if;
2141
2142       for Indx in reverse Index_Type'First .. Last loop
2143          if Container.Elements (Indx) /= null
2144            and then Container.Elements (Indx).all = Item
2145          then
2146             return Indx;
2147          end if;
2148       end loop;
2149
2150       return No_Index;
2151    end Reverse_Find_Index;
2152
2153    ---------------------
2154    -- Reverse_Iterate --
2155    ---------------------
2156
2157    procedure Reverse_Iterate
2158      (Container : Vector;
2159       Process   : not null access procedure (Position : in Cursor))
2160    is
2161       V : Vector renames Container'Unrestricted_Access.all;
2162       B : Natural renames V.Busy;
2163
2164    begin
2165       B := B + 1;
2166
2167       begin
2168          for Indx in reverse Index_Type'First .. Container.Last loop
2169             Process (Cursor'(Container'Unchecked_Access, Indx));
2170          end loop;
2171       exception
2172          when others =>
2173             B := B - 1;
2174             raise;
2175       end;
2176
2177       B := B - 1;
2178    end Reverse_Iterate;
2179
2180    ----------------
2181    -- Set_Length --
2182    ----------------
2183
2184    procedure Set_Length
2185      (Container : in out Vector;
2186       Length    : Count_Type)
2187    is
2188       N : constant Count_Type := Indefinite_Vectors.Length (Container);
2189
2190    begin
2191       if Length = N then
2192          return;
2193       end if;
2194
2195       if Container.Busy > 0 then
2196          raise Program_Error;
2197       end if;
2198
2199       if Length < N then
2200          for Index in 1 .. N - Length loop
2201             declare
2202                J : constant Index_Type := Container.Last;
2203                X : Element_Access := Container.Elements (J);
2204
2205             begin
2206                Container.Elements (J) := null;
2207                Container.Last := J - 1;
2208                Free (X);
2209             end;
2210          end loop;
2211
2212          return;
2213       end if;
2214
2215       if Length > Capacity (Container) then
2216          Reserve_Capacity (Container, Capacity => Length);
2217       end if;
2218
2219       declare
2220          Last_As_Int : constant Int'Base :=
2221                          Int (Index_Type'First) + Int (Length) - 1;
2222
2223       begin
2224          Container.Last := Index_Type (Last_As_Int);
2225       end;
2226    end Set_Length;
2227
2228    ----------
2229    -- Swap --
2230    ----------
2231
2232    procedure Swap
2233      (Container : Vector;
2234       I, J      : Index_Type)
2235    is
2236    begin
2237       if I > Container.Last
2238         or else J > Container.Last
2239       then
2240          raise Constraint_Error;
2241       end if;
2242
2243       if I = J then
2244          return;
2245       end if;
2246
2247       if Container.Lock > 0 then
2248          raise Program_Error;
2249       end if;
2250
2251       declare
2252          EI : Element_Access renames Container.Elements (I);
2253          EJ : Element_Access renames Container.Elements (J);
2254
2255          EI_Copy : constant Element_Access := EI;
2256
2257       begin
2258          EI := EJ;
2259          EJ := EI_Copy;
2260       end;
2261    end Swap;
2262
2263    procedure Swap (I, J : Cursor)
2264    is
2265    begin
2266       if I.Container = null
2267         or else J.Container = null
2268       then
2269          raise Constraint_Error;
2270       end if;
2271
2272       if I.Container /= J.Container then
2273          raise Program_Error;
2274       end if;
2275
2276       Swap (I.Container.all, I.Index, J.Index);
2277    end Swap;
2278
2279    ---------------
2280    -- To_Cursor --
2281    ---------------
2282
2283    function To_Cursor
2284      (Container : Vector;
2285       Index     : Extended_Index) return Cursor
2286    is
2287    begin
2288       if Index not in Index_Type'First .. Container.Last then
2289          return No_Element;
2290       end if;
2291
2292       return Cursor'(Container'Unchecked_Access, Index);
2293    end To_Cursor;
2294
2295    --------------
2296    -- To_Index --
2297    --------------
2298
2299    function To_Index (Position : Cursor) return Extended_Index is
2300    begin
2301       if Position.Container = null then
2302          return No_Index;
2303       end if;
2304
2305       if Position.Index <= Position.Container.Last then
2306          return Position.Index;
2307       end if;
2308
2309       return No_Index;
2310    end To_Index;
2311
2312    ---------------
2313    -- To_Vector --
2314    ---------------
2315
2316    function To_Vector (Length : Count_Type) return Vector is
2317    begin
2318       if Length = 0 then
2319          return Empty_Vector;
2320       end if;
2321
2322       declare
2323          First       : constant Int := Int (Index_Type'First);
2324          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2325          Last        : Index_Type;
2326          Elements    : Elements_Access;
2327
2328       begin
2329          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2330             raise Constraint_Error;
2331          end if;
2332
2333          Last := Index_Type (Last_As_Int);
2334          Elements := new Elements_Type (Index_Type'First .. Last);
2335
2336          return (Controlled with Elements, Last, 0, 0);
2337       end;
2338    end To_Vector;
2339
2340    function To_Vector
2341      (New_Item : Element_Type;
2342       Length   : Count_Type) return Vector
2343    is
2344    begin
2345       if Length = 0 then
2346          return Empty_Vector;
2347       end if;
2348
2349       declare
2350          First       : constant Int := Int (Index_Type'First);
2351          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2352          Last        : Index_Type'Base;
2353          Elements    : Elements_Access;
2354
2355       begin
2356          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2357             raise Constraint_Error;
2358          end if;
2359
2360          Last := Index_Type (Last_As_Int);
2361          Elements := new Elements_Type (Index_Type'First .. Last);
2362
2363          Last := Index_Type'First;
2364
2365          begin
2366             loop
2367                Elements (Last) := new Element_Type'(New_Item);
2368                exit when Last = Elements'Last;
2369                Last := Last + 1;
2370             end loop;
2371          exception
2372             when others =>
2373                for J in Index_Type'First .. Last - 1 loop
2374                   Free (Elements (J));
2375                end loop;
2376
2377                Free (Elements);
2378                raise;
2379          end;
2380
2381          return (Controlled with Elements, Last, 0, 0);
2382       end;
2383    end To_Vector;
2384
2385    --------------------
2386    -- Update_Element --
2387    --------------------
2388
2389    procedure Update_Element
2390      (Container : Vector;
2391       Index     : Index_Type;
2392       Process   : not null access procedure (Element : in out Element_Type))
2393    is
2394       V : Vector renames Container'Unrestricted_Access.all;
2395       B : Natural renames V.Busy;
2396       L : Natural renames V.Lock;
2397
2398    begin
2399       if Index > Container.Last then
2400          raise Constraint_Error;
2401       end if;
2402
2403       B := B + 1;
2404       L := L + 1;
2405
2406       begin
2407          Process (V.Elements (Index).all);
2408       exception
2409          when others =>
2410             L := L - 1;
2411             B := B - 1;
2412             raise;
2413       end;
2414
2415       L := L - 1;
2416       B := B - 1;
2417    end Update_Element;
2418
2419    procedure Update_Element
2420      (Position : Cursor;
2421       Process  : not null access procedure (Element : in out Element_Type))
2422    is
2423    begin
2424       if Position.Container = null then
2425          raise Constraint_Error;
2426       end if;
2427
2428       Update_Element (Position.Container.all, Position.Index, Process);
2429    end Update_Element;
2430
2431    -----------
2432    -- Write --
2433    -----------
2434
2435    procedure Write
2436      (Stream    : access Root_Stream_Type'Class;
2437       Container : Vector)
2438    is
2439       N : constant Count_Type := Length (Container);
2440
2441    begin
2442       Count_Type'Base'Write (Stream, N);
2443
2444       if N = 0 then
2445          return;
2446       end if;
2447
2448       declare
2449          E : Elements_Type renames Container.Elements.all;
2450
2451       begin
2452          for Indx in Index_Type'First .. Container.Last loop
2453
2454             --  There's another way to do this.  Instead a separate
2455             --  Boolean for each element, you could write a Boolean
2456             --  followed by a count of how many nulls or non-nulls
2457             --  follow in the array.
2458
2459             if E (Indx) = null then
2460                Boolean'Write (Stream, False);
2461             else
2462                Boolean'Write (Stream, True);
2463                Element_Type'Output (Stream, E (Indx).all);
2464             end if;
2465          end loop;
2466       end;
2467    end Write;
2468
2469 end Ada.Containers.Indefinite_Vectors;