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    -- 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             if I < Index_Type'First then
 899                declare
 900                   Src : Elements_Type renames
 901                     Source.Elements (Index_Type'First .. Source.Last);
 902
 903                begin
 904                   Target.Elements (Index_Type'First .. J) := Src;
 905                   Src := (others => null);
 906                end;
 907
 908                Source.Last := No_Index;
 909                return;
 910             end if;
 911
 912             declare
 913                Src : Element_Access renames Source.Elements (Source.Last);
 914                Tgt : Element_Access renames Target.Elements (I);
 915
 916             begin
 917                if Is_Less (Src, Tgt) then
 918                   Target.Elements (J) := Tgt;
 919                   Tgt := null;
 920                   I := I - 1;
 921
 922                else
 923                   Target.Elements (J) := Src;
 924                   Src := null;
 925                   Source.Last := Source.Last - 1;
 926                end if;
 927             end;
 928
 929             J := J - 1;
 930          end loop;
 931       end Merge;
 932
 933       ----------
 934       -- Sort --
 935       ----------
 936
 937       procedure Sort (Container : in out Vector)
 938       is
 939          procedure Sort is
 940             new Generic_Array_Sort
 941              (Index_Type   => Index_Type,
 942               Element_Type => Element_Access,
 943               Array_Type   => Elements_Type,
 944               "<"          => Is_Less);
 945
 946       --  Start of processing for Sort
 947
 948       begin
 949          if Container.Last <= Index_Type'First then
 950             return;
 951          end if;
 952
 953          if Container.Lock > 0 then
 954             raise Program_Error;
 955          end if;
 956
 957          Sort (Container.Elements (Index_Type'First .. Container.Last));
 958       end Sort;
 959
 960    end Generic_Sorting;
 961
 962    -----------------
 963    -- Has_Element --
 964    -----------------
 965
 966    function Has_Element (Position : Cursor) return Boolean is
 967    begin
 968       if Position.Container = null then
 969          return False;
 970       end if;
 971
 972       return Position.Index <= Position.Container.Last;
 973    end Has_Element;
 974
 975    ------------
 976    -- Insert --
 977    ------------
 978
 979    procedure Insert
 980      (Container : in out Vector;
 981       Before    : Extended_Index;
 982       New_Item  : Element_Type;
 983       Count     : Count_Type := 1)
 984    is
 985       N : constant Int := Int (Count);
 986
 987       New_Last_As_Int : Int'Base;
 988       New_Last        : Index_Type;
 989
 990       Dst : Elements_Access;
 991
 992    begin
 993       if Before < Index_Type'First then
 994          raise Constraint_Error;
 995       end if;
 996
 997       if Before > Container.Last
 998         and then Before > Container.Last + 1
 999       then
1000          raise Constraint_Error;
1001       end if;
1002
1003       if Count = 0 then
1004          return;
1005       end if;
1006
1007       declare
1008          Old_Last_As_Int : constant Int := Int (Container.Last);
1009
1010       begin
1011          New_Last_As_Int := Old_Last_As_Int + N;
1012
1013          if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1014             raise Constraint_Error;
1015          end if;
1016
1017          New_Last := Index_Type (New_Last_As_Int);
1018       end;
1019
1020       if Container.Busy > 0 then
1021          raise Program_Error;
1022       end if;
1023
1024       if Container.Elements = null then
1025          Container.Elements :=
1026            new Elements_Type (Index_Type'First .. New_Last);
1027
1028          Container.Last := No_Index;
1029
1030          for J in Container.Elements'Range loop
1031             Container.Elements (J) := new Element_Type'(New_Item);
1032             Container.Last := J;
1033          end loop;
1034
1035          return;
1036       end if;
1037
1038       if New_Last <= Container.Elements'Last then
1039          declare
1040             E : Elements_Type renames Container.Elements.all;
1041          begin
1042             if Before <= Container.Last then
1043                declare
1044                   Index_As_Int : constant Int'Base :=
1045                                    Index_Type'Pos (Before) + N;
1046
1047                   Index : constant Index_Type := Index_Type (Index_As_Int);
1048
1049                   J : Index_Type'Base := Before;
1050
1051                begin
1052                   E (Index .. New_Last) := E (Before .. Container.Last);
1053                   Container.Last := New_Last;
1054
1055                   while J < Index loop
1056                      E (J) := new Element_Type'(New_Item);
1057                      J := J + 1;
1058                   end loop;
1059                exception
1060                   when others =>
1061                      E (J .. Index - 1) := (others => null);
1062                      raise;
1063                end;
1064
1065             else
1066                for J in Before .. New_Last loop
1067                   E (J) := new Element_Type'(New_Item);
1068                   Container.Last := J;
1069                end loop;
1070             end if;
1071          end;
1072
1073          return;
1074       end if;
1075
1076       declare
1077          First    : constant Int := Int (Index_Type'First);
1078          New_Size : constant Int'Base := New_Last_As_Int - First + 1;
1079          Size     : Int'Base := Int'Max (1, Container.Elements'Length);
1080
1081       begin
1082          while Size < New_Size loop
1083             if Size > Int'Last / 2 then
1084                Size := Int'Last;
1085                exit;
1086             end if;
1087
1088             Size := 2 * Size;
1089          end loop;
1090
1091          --  TODO: The following calculations aren't quite right, since
1092          --  there will be overflow if Index_Type'Range is very large
1093          --  (e.g. this package is instantiated with a 64-bit integer).
1094          --  END TODO.
1095
1096          declare
1097             Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1;
1098          begin
1099             if Size > Max_Size then
1100                Size := Max_Size;
1101             end if;
1102          end;
1103
1104          declare
1105             Dst_Last : constant Index_Type := Index_Type (First + Size - 1);
1106          begin
1107             Dst := new Elements_Type (Index_Type'First .. Dst_Last);
1108          end;
1109       end;
1110
1111       if Before <= Container.Last then
1112          declare
1113             Index_As_Int : constant Int'Base :=
1114                              Index_Type'Pos (Before) + N;
1115
1116             Index : constant Index_Type := Index_Type (Index_As_Int);
1117
1118             Src : Elements_Access := Container.Elements;
1119
1120          begin
1121             Dst (Index_Type'First .. Before - 1) :=
1122               Src (Index_Type'First .. Before - 1);
1123
1124             Dst (Index .. New_Last) := Src (Before .. Container.Last);
1125
1126             Container.Elements := Dst;
1127             Container.Last := New_Last;
1128             Free (Src);
1129
1130             for J in Before .. Index - 1 loop
1131                Dst (J) := new Element_Type'(New_Item);
1132             end loop;
1133          end;
1134
1135       else
1136          declare
1137             Src : Elements_Access := Container.Elements;
1138
1139          begin
1140             Dst (Index_Type'First .. Container.Last) :=
1141               Src (Index_Type'First .. Container.Last);
1142
1143             Container.Elements := Dst;
1144             Free (Src);
1145
1146             for J in Before .. New_Last loop
1147                Dst (J) := new Element_Type'(New_Item);
1148                Container.Last := J;
1149             end loop;
1150          end;
1151       end if;
1152    end Insert;
1153
1154    procedure Insert
1155      (Container : in out Vector;
1156       Before    : Extended_Index;
1157       New_Item  : Vector)
1158    is
1159       N : constant Count_Type := Length (New_Item);
1160
1161    begin
1162       if Before < Index_Type'First then
1163          raise Constraint_Error;
1164       end if;
1165
1166       if Before > Container.Last
1167         and then Before > Container.Last + 1
1168       then
1169          raise Constraint_Error;
1170       end if;
1171
1172       if N = 0 then
1173          return;
1174       end if;
1175
1176       Insert_Space (Container, Before, Count => N);
1177
1178       declare
1179          Dst_Last_As_Int : constant Int'Base :=
1180                              Int'Base (Before) + Int'Base (N) - 1;
1181
1182          Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
1183
1184          Dst : Elements_Type renames
1185                  Container.Elements (Before .. Dst_Last);
1186
1187          Dst_Index : Index_Type'Base := Before - 1;
1188
1189       begin
1190          if Container'Address /= New_Item'Address then
1191             declare
1192                Src : Elements_Type renames
1193                        New_Item.Elements (Index_Type'First .. New_Item.Last);
1194
1195             begin
1196                for Src_Index in Src'Range loop
1197                   Dst_Index := Dst_Index + 1;
1198
1199                   if Src (Src_Index) /= null then
1200                      Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1201                   end if;
1202                end loop;
1203             end;
1204
1205             return;
1206          end if;
1207
1208          declare
1209             subtype Src_Index_Subtype is Index_Type'Base range
1210               Index_Type'First .. Before - 1;
1211
1212             Src : Elements_Type renames
1213                     Container.Elements (Src_Index_Subtype);
1214
1215          begin
1216             for Src_Index in Src'Range loop
1217                Dst_Index := Dst_Index + 1;
1218
1219                if Src (Src_Index) /= null then
1220                   Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1221                end if;
1222             end loop;
1223          end;
1224
1225          if Dst_Last = Container.Last then
1226             return;
1227          end if;
1228
1229          declare
1230             subtype Src_Index_Subtype is Index_Type'Base range
1231               Dst_Last + 1 .. Container.Last;
1232
1233             Src : Elements_Type renames
1234                     Container.Elements (Src_Index_Subtype);
1235
1236          begin
1237             for Src_Index in Src'Range loop
1238                Dst_Index := Dst_Index + 1;
1239
1240                if Src (Src_Index) /= null then
1241                   Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1242                end if;
1243             end loop;
1244          end;
1245       end;
1246    end Insert;
1247
1248    procedure Insert
1249      (Container : in out Vector;
1250       Before    : Cursor;
1251       New_Item  : Vector)
1252    is
1253       Index : Index_Type'Base;
1254
1255    begin
1256       if Before.Container /= null
1257         and then Before.Container /= Container'Unchecked_Access
1258       then
1259          raise Program_Error;
1260       end if;
1261
1262       if Is_Empty (New_Item) then
1263          return;
1264       end if;
1265
1266       if Before.Container = null
1267         or else Before.Index > Container.Last
1268       then
1269          if Container.Last = Index_Type'Last then
1270             raise Constraint_Error;
1271          end if;
1272
1273          Index := Container.Last + 1;
1274
1275       else
1276          Index := Before.Index;
1277       end if;
1278
1279       Insert (Container, Index, New_Item);
1280    end Insert;
1281
1282    procedure Insert
1283      (Container : in out Vector;
1284       Before    : Cursor;
1285       New_Item  : Vector;
1286       Position  : out Cursor)
1287    is
1288       Index : Index_Type'Base;
1289
1290    begin
1291       if Before.Container /= null
1292         and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1293       then
1294          raise Program_Error;
1295       end if;
1296
1297       if Is_Empty (New_Item) then
1298          if Before.Container = null
1299            or else Before.Index > Container.Last
1300          then
1301             Position := No_Element;
1302          else
1303             Position := (Container'Unchecked_Access, Before.Index);
1304          end if;
1305
1306          return;
1307       end if;
1308
1309       if Before.Container = null
1310         or else Before.Index > Container.Last
1311       then
1312          if Container.Last = Index_Type'Last then
1313             raise Constraint_Error;
1314          end if;
1315
1316          Index := Container.Last + 1;
1317
1318       else
1319          Index := Before.Index;
1320       end if;
1321
1322       Insert (Container, Index, New_Item);
1323
1324       Position := Cursor'(Container'Unchecked_Access, Index);
1325    end Insert;
1326
1327    procedure Insert
1328      (Container : in out Vector;
1329       Before    : Cursor;
1330       New_Item  : Element_Type;
1331       Count     : Count_Type := 1)
1332    is
1333       Index : Index_Type'Base;
1334
1335    begin
1336       if Before.Container /= null
1337         and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1338       then
1339          raise Program_Error;
1340       end if;
1341
1342       if Count = 0 then
1343          return;
1344       end if;
1345
1346       if Before.Container = null
1347         or else Before.Index > Container.Last
1348       then
1349          if Container.Last = Index_Type'Last then
1350             raise Constraint_Error;
1351          end if;
1352
1353          Index := Container.Last + 1;
1354
1355       else
1356          Index := Before.Index;
1357       end if;
1358
1359       Insert (Container, Index, New_Item, Count);
1360    end Insert;
1361
1362    procedure Insert
1363      (Container : in out Vector;
1364       Before    : Cursor;
1365       New_Item  : Element_Type;
1366       Position  : out Cursor;
1367       Count     : Count_Type := 1)
1368    is
1369       Index : Index_Type'Base;
1370
1371    begin
1372       if Before.Container /= null
1373         and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1374       then
1375          raise Program_Error;
1376       end if;
1377
1378       if Count = 0 then
1379          if Before.Container = null
1380            or else Before.Index > Container.Last
1381          then
1382             Position := No_Element;
1383          else
1384             Position := (Container'Unchecked_Access, Before.Index);
1385          end if;
1386
1387          return;
1388       end if;
1389
1390       if Before.Container = null
1391         or else Before.Index > Container.Last
1392       then
1393          if Container.Last = Index_Type'Last then
1394             raise Constraint_Error;
1395          end if;
1396
1397          Index := Container.Last + 1;
1398
1399       else
1400          Index := Before.Index;
1401       end if;
1402
1403       Insert (Container, Index, New_Item, Count);
1404
1405       Position := (Container'Unchecked_Access, Index);
1406    end Insert;
1407
1408    ------------------
1409    -- Insert_Space --
1410    ------------------
1411
1412    procedure Insert_Space
1413      (Container : in out Vector;
1414       Before    : Extended_Index;
1415       Count     : Count_Type := 1)
1416    is
1417       N : constant Int := Int (Count);
1418
1419       New_Last_As_Int : Int'Base;
1420       New_Last        : Index_Type;
1421
1422       Dst : Elements_Access;
1423
1424    begin
1425       if Before < Index_Type'First then
1426          raise Constraint_Error;
1427       end if;
1428
1429       if Before > Container.Last
1430         and then Before > Container.Last + 1
1431       then
1432          raise Constraint_Error;
1433       end if;
1434
1435       if Count = 0 then
1436          return;
1437       end if;
1438
1439       declare
1440          Old_Last_As_Int : constant Int := Int (Container.Last);
1441
1442       begin
1443          New_Last_As_Int := Old_Last_As_Int + N;
1444
1445          if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1446             raise Constraint_Error;
1447          end if;
1448
1449          New_Last := Index_Type (New_Last_As_Int);
1450       end;
1451
1452       if Container.Busy > 0 then
1453          raise Program_Error;
1454       end if;
1455
1456       if Container.Elements = null then
1457          Container.Elements :=
1458            new Elements_Type (Index_Type'First .. New_Last);
1459
1460          Container.Last := New_Last;
1461          return;
1462       end if;
1463
1464       if New_Last <= Container.Elements'Last then
1465          declare
1466             E : Elements_Type renames Container.Elements.all;
1467
1468          begin
1469             if Before <= Container.Last then
1470                declare
1471                   Index_As_Int : constant Int'Base :=
1472                                    Index_Type'Pos (Before) + N;
1473
1474                   Index : constant Index_Type := Index_Type (Index_As_Int);
1475
1476                begin
1477                   E (Index .. New_Last) := E (Before .. Container.Last);
1478                   E (Before .. Index - 1) := (others => null);
1479                end;
1480             end if;
1481          end;
1482
1483          Container.Last := New_Last;
1484          return;
1485       end if;
1486
1487       declare
1488          First    : constant Int := Int (Index_Type'First);
1489          New_Size : constant Int'Base := New_Last_As_Int - First + 1;
1490          Size     : Int'Base := Int'Max (1, Container.Elements'Length);
1491
1492       begin
1493          while Size < New_Size loop
1494             if Size > Int'Last / 2 then
1495                Size := Int'Last;
1496                exit;
1497             end if;
1498
1499             Size := 2 * Size;
1500          end loop;
1501
1502          --  TODO: The following calculations aren't quite right, since
1503          --  there will be overflow if Index_Type'Range is very large
1504          --  (e.g. this package is instantiated with a 64-bit integer).
1505          --  END TODO.
1506
1507          declare
1508             Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1;
1509          begin
1510             if Size > Max_Size then
1511                Size := Max_Size;
1512             end if;
1513          end;
1514
1515          declare
1516             Dst_Last : constant Index_Type := Index_Type (First + Size - 1);
1517          begin
1518             Dst := new Elements_Type (Index_Type'First .. Dst_Last);
1519          end;
1520       end;
1521
1522       declare
1523          Src : Elements_Access := Container.Elements;
1524
1525       begin
1526          if Before <= Container.Last then
1527             declare
1528                Index_As_Int : constant Int'Base :=
1529                                 Index_Type'Pos (Before) + N;
1530
1531                Index : constant Index_Type := Index_Type (Index_As_Int);
1532
1533             begin
1534                Dst (Index_Type'First .. Before - 1) :=
1535                  Src (Index_Type'First .. Before - 1);
1536
1537                Dst (Index .. New_Last) := Src (Before .. Container.Last);
1538             end;
1539
1540          else
1541             Dst (Index_Type'First .. Container.Last) :=
1542               Src (Index_Type'First .. Container.Last);
1543          end if;
1544
1545          Container.Elements := Dst;
1546          Container.Last := New_Last;
1547          Free (Src);
1548       end;
1549    end Insert_Space;
1550
1551    procedure Insert_Space
1552      (Container : in out Vector;
1553       Before    : Cursor;
1554       Position  : out Cursor;
1555       Count     : Count_Type := 1)
1556    is
1557       Index : Index_Type'Base;
1558
1559    begin
1560       if Before.Container /= null
1561         and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1562       then
1563          raise Program_Error;
1564       end if;
1565
1566       if Count = 0 then
1567          if Before.Container = null
1568            or else Before.Index > Container.Last
1569          then
1570             Position := No_Element;
1571          else
1572             Position := (Container'Unchecked_Access, Before.Index);
1573          end if;
1574
1575          return;
1576       end if;
1577
1578       if Before.Container = null
1579         or else Before.Index > Container.Last
1580       then
1581          if Container.Last = Index_Type'Last then
1582             raise Constraint_Error;
1583          end if;
1584
1585          Index := Container.Last + 1;
1586
1587       else
1588          Index := Before.Index;
1589       end if;
1590
1591       Insert_Space (Container, Index, Count);
1592
1593       Position := Cursor'(Container'Unchecked_Access, Index);
1594    end Insert_Space;
1595
1596    --------------
1597    -- Is_Empty --
1598    --------------
1599
1600    function Is_Empty (Container : Vector) return Boolean is
1601    begin
1602       return Container.Last < Index_Type'First;
1603    end Is_Empty;
1604
1605    -------------
1606    -- Iterate --
1607    -------------
1608
1609    procedure Iterate
1610      (Container : Vector;
1611       Process   : not null access procedure (Position : in Cursor))
1612    is
1613       V : Vector renames Container'Unrestricted_Access.all;
1614       B : Natural renames V.Busy;
1615
1616    begin
1617       B := B + 1;
1618
1619       begin
1620          for Indx in Index_Type'First .. Container.Last loop
1621             Process (Cursor'(Container'Unchecked_Access, Indx));
1622          end loop;
1623       exception
1624          when others =>
1625             B := B - 1;
1626             raise;
1627       end;
1628
1629       B := B - 1;
1630    end Iterate;
1631
1632    ----------
1633    -- Last --
1634    ----------
1635
1636    function Last (Container : Vector) return Cursor is
1637    begin
1638       if Is_Empty (Container) then
1639          return No_Element;
1640       end if;
1641
1642       return (Container'Unchecked_Access, Container.Last);
1643    end Last;
1644
1645    ------------------
1646    -- Last_Element --
1647    ------------------
1648
1649    function Last_Element (Container : Vector) return Element_Type is
1650    begin
1651       return Element (Container, Container.Last);
1652    end Last_Element;
1653
1654    ----------------
1655    -- Last_Index --
1656    ----------------
1657
1658    function Last_Index (Container : Vector) return Extended_Index is
1659    begin
1660       return Container.Last;
1661    end Last_Index;
1662
1663    ------------
1664    -- Length --
1665    ------------
1666
1667    function Length (Container : Vector) return Count_Type is
1668       L : constant Int := Int (Container.Last);
1669       F : constant Int := Int (Index_Type'First);
1670       N : constant Int'Base := L - F + 1;
1671
1672    begin
1673       if N > Count_Type'Pos (Count_Type'Last) then
1674          raise Constraint_Error;
1675       end if;
1676
1677       return Count_Type (N);
1678    end Length;
1679
1680    ----------
1681    -- Move --
1682    ----------
1683
1684    procedure Move
1685      (Target : in out Vector;
1686       Source : in out Vector)
1687    is
1688    begin
1689       if Target'Address = Source'Address then
1690          return;
1691       end if;
1692
1693       if Source.Busy > 0 then
1694          raise Program_Error;
1695       end if;
1696
1697       Clear (Target);
1698
1699       declare
1700          Target_Elements : constant Elements_Access := Target.Elements;
1701       begin
1702          Target.Elements := Source.Elements;
1703          Source.Elements := Target_Elements;
1704       end;
1705
1706       Target.Last := Source.Last;
1707       Source.Last := No_Index;
1708    end Move;
1709
1710    ----------
1711    -- Next --
1712    ----------
1713
1714    function Next (Position : Cursor) return Cursor is
1715    begin
1716       if Position.Container = null then
1717          return No_Element;
1718       end if;
1719
1720       if Position.Index < Position.Container.Last then
1721          return (Position.Container, Position.Index + 1);
1722       end if;
1723
1724       return No_Element;
1725    end Next;
1726
1727    ----------
1728    -- Next --
1729    ----------
1730
1731    procedure Next (Position : in out Cursor) is
1732    begin
1733       if Position.Container = null then
1734          return;
1735       end if;
1736
1737       if Position.Index < Position.Container.Last then
1738          Position.Index := Position.Index + 1;
1739       else
1740          Position := No_Element;
1741       end if;
1742    end Next;
1743
1744    -------------
1745    -- Prepend --
1746    -------------
1747
1748    procedure Prepend (Container : in out Vector; New_Item : Vector) is
1749    begin
1750       Insert (Container, Index_Type'First, New_Item);
1751    end Prepend;
1752
1753    procedure Prepend
1754      (Container : in out Vector;
1755       New_Item  : Element_Type;
1756       Count     : Count_Type := 1)
1757    is
1758    begin
1759       Insert (Container,
1760               Index_Type'First,
1761               New_Item,
1762               Count);
1763    end Prepend;
1764
1765    --------------
1766    -- Previous --
1767    --------------
1768
1769    procedure Previous (Position : in out Cursor) is
1770    begin
1771       if Position.Container = null then
1772          return;
1773       end if;
1774
1775       if Position.Index > Index_Type'First then
1776          Position.Index := Position.Index - 1;
1777       else
1778          Position := No_Element;
1779       end if;
1780    end Previous;
1781
1782    function Previous (Position : Cursor) return Cursor is
1783    begin
1784       if Position.Container = null then
1785          return No_Element;
1786       end if;
1787
1788       if Position.Index > Index_Type'First then
1789          return (Position.Container, Position.Index - 1);
1790       end if;
1791
1792       return No_Element;
1793    end Previous;
1794
1795    -------------------
1796    -- Query_Element --
1797    -------------------
1798
1799    procedure Query_Element
1800      (Container : Vector;
1801       Index     : Index_Type;
1802       Process   : not null access procedure (Element : in Element_Type))
1803    is
1804       V : Vector renames Container'Unrestricted_Access.all;
1805       B : Natural renames V.Busy;
1806       L : Natural renames V.Lock;
1807
1808    begin
1809       if Index > Container.Last then
1810          raise Constraint_Error;
1811       end if;
1812
1813       if V.Elements (Index) = null then
1814          raise Constraint_Error;
1815       end if;
1816
1817       B := B + 1;
1818       L := L + 1;
1819
1820       begin
1821          Process (V.Elements (Index).all);
1822       exception
1823          when others =>
1824             L := L - 1;
1825             B := B - 1;
1826             raise;
1827       end;
1828
1829       L := L - 1;
1830       B := B - 1;
1831    end Query_Element;
1832
1833    procedure Query_Element
1834      (Position : Cursor;
1835       Process  : not null access procedure (Element : in Element_Type))
1836    is
1837    begin
1838       if Position.Container = null then
1839          raise Constraint_Error;
1840       end if;
1841
1842       Query_Element (Position.Container.all, Position.Index, Process);
1843    end Query_Element;
1844
1845    ----------
1846    -- Read --
1847    ----------
1848
1849    procedure Read
1850      (Stream    : access Root_Stream_Type'Class;
1851       Container : out Vector)
1852    is
1853       Length : Count_Type'Base;
1854       Last   : Index_Type'Base := Index_Type'Pred (Index_Type'First);
1855
1856       B : Boolean;
1857
1858    begin
1859       Clear (Container);
1860
1861       Count_Type'Base'Read (Stream, Length);
1862
1863       if Length > Capacity (Container) then
1864          Reserve_Capacity (Container, Capacity => Length);
1865       end if;
1866
1867       for J in Count_Type range 1 .. Length loop
1868          Last := Last + 1;
1869
1870          Boolean'Read (Stream, B);
1871
1872          if B then
1873             Container.Elements (Last) :=
1874               new Element_Type'(Element_Type'Input (Stream));
1875          end if;
1876
1877          Container.Last := Last;
1878       end loop;
1879    end Read;
1880
1881    procedure Read
1882      (Stream   : access Root_Stream_Type'Class;
1883       Position : out Cursor)
1884    is
1885    begin
1886       raise Program_Error;
1887    end Read;
1888
1889    ---------------------
1890    -- Replace_Element --
1891    ---------------------
1892
1893    procedure Replace_Element
1894      (Container : in out Vector;
1895       Index     : Index_Type;
1896       New_Item  : Element_Type)
1897    is
1898    begin
1899       if Index > Container.Last then
1900          raise Constraint_Error;
1901       end if;
1902
1903       if Container.Lock > 0 then
1904          raise Program_Error;
1905       end if;
1906
1907       declare
1908          X : Element_Access := Container.Elements (Index);
1909       begin
1910          Container.Elements (Index) := new Element_Type'(New_Item);
1911          Free (X);
1912       end;
1913    end Replace_Element;
1914
1915    procedure Replace_Element
1916      (Container : in out Vector;
1917       Position  : Cursor;
1918       New_Item  : Element_Type)
1919    is
1920    begin
1921       if Position.Container = null then
1922          raise Constraint_Error;
1923       end if;
1924
1925       if Position.Container /= Container'Unrestricted_Access then
1926          raise Program_Error;
1927       end if;
1928
1929       Replace_Element (Container, Position.Index, New_Item);
1930    end Replace_Element;
1931
1932    ----------------------
1933    -- Reserve_Capacity --
1934    ----------------------
1935
1936    procedure Reserve_Capacity
1937      (Container : in out Vector;
1938       Capacity  : Count_Type)
1939    is
1940       N : constant Count_Type := Length (Container);
1941
1942    begin
1943       if Capacity = 0 then
1944          if N = 0 then
1945             declare
1946                X : Elements_Access := Container.Elements;
1947             begin
1948                Container.Elements := null;
1949                Free (X);
1950             end;
1951
1952          elsif N < Container.Elements'Length then
1953             if Container.Busy > 0 then
1954                raise Program_Error;
1955             end if;
1956
1957             declare
1958                subtype Array_Index_Subtype is Index_Type'Base range
1959                  Index_Type'First .. Container.Last;
1960
1961                Src : Elements_Type renames
1962                        Container.Elements (Array_Index_Subtype);
1963
1964                subtype Array_Subtype is
1965                  Elements_Type (Array_Index_Subtype);
1966
1967                X : Elements_Access := Container.Elements;
1968
1969             begin
1970                Container.Elements := new Array_Subtype'(Src);
1971                Free (X);
1972             end;
1973          end if;
1974
1975          return;
1976       end if;
1977
1978       if Container.Elements = null then
1979          declare
1980             Last_As_Int : constant Int'Base :=
1981                             Int (Index_Type'First) + Int (Capacity) - 1;
1982
1983          begin
1984             if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1985                raise Constraint_Error;
1986             end if;
1987
1988             declare
1989                Last : constant Index_Type := Index_Type (Last_As_Int);
1990
1991                subtype Array_Subtype is
1992                  Elements_Type (Index_Type'First .. Last);
1993
1994             begin
1995                Container.Elements := new Array_Subtype;
1996             end;
1997          end;
1998
1999          return;
2000       end if;
2001
2002       if Capacity <= N then
2003          if N < Container.Elements'Length then
2004             if Container.Busy > 0 then
2005                raise Program_Error;
2006             end if;
2007
2008             declare
2009                subtype Array_Index_Subtype is Index_Type'Base range
2010                  Index_Type'First .. Container.Last;
2011
2012                Src : Elements_Type renames
2013                        Container.Elements (Array_Index_Subtype);
2014
2015                subtype Array_Subtype is
2016                  Elements_Type (Array_Index_Subtype);
2017
2018                X : Elements_Access := Container.Elements;
2019
2020             begin
2021                Container.Elements := new Array_Subtype'(Src);
2022                Free (X);
2023             end;
2024          end if;
2025
2026          return;
2027       end if;
2028
2029       if Capacity = Container.Elements'Length then
2030          return;
2031       end if;
2032
2033       if Container.Busy > 0 then
2034          raise Program_Error;
2035       end if;
2036
2037       declare
2038          Last_As_Int : constant Int'Base :=
2039                          Int (Index_Type'First) + Int (Capacity) - 1;
2040
2041       begin
2042          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2043             raise Constraint_Error;
2044          end if;
2045
2046          declare
2047             Last : constant Index_Type := Index_Type (Last_As_Int);
2048
2049             subtype Array_Subtype is
2050               Elements_Type (Index_Type'First .. Last);
2051
2052             X : Elements_Access := Container.Elements;
2053
2054          begin
2055             Container.Elements := new Array_Subtype;
2056
2057             declare
2058                Src : Elements_Type renames
2059                        X (Index_Type'First .. Container.Last);
2060
2061                Tgt : Elements_Type renames
2062                        Container.Elements (Index_Type'First .. Container.Last);
2063
2064             begin
2065                Tgt := Src;
2066             end;
2067
2068             Free (X);
2069          end;
2070       end;
2071    end Reserve_Capacity;
2072
2073    ----------------------
2074    -- Reverse_Elements --
2075    ----------------------
2076
2077    procedure Reverse_Elements (Container : in out Vector) is
2078    begin
2079       if Container.Length <= 1 then
2080          return;
2081       end if;
2082
2083       if Container.Lock > 0 then
2084          raise Program_Error;
2085       end if;
2086
2087       declare
2088          I : Index_Type := Index_Type'First;
2089          J : Index_Type := Container.Last;
2090          E : Elements_Type renames Container.Elements.all;
2091
2092       begin
2093          while I < J loop
2094             declare
2095                EI : constant Element_Access := E (I);
2096
2097             begin
2098                E (I) := E (J);
2099                E (J) := EI;
2100             end;
2101
2102             I := I + 1;
2103             J := J - 1;
2104          end loop;
2105       end;
2106    end Reverse_Elements;
2107
2108    ------------------
2109    -- Reverse_Find --
2110    ------------------
2111
2112    function Reverse_Find
2113      (Container : Vector;
2114       Item      : Element_Type;
2115       Position  : Cursor := No_Element) return Cursor
2116    is
2117       Last : Index_Type'Base;
2118
2119    begin
2120       if Position.Container /= null
2121         and then Position.Container /= Container'Unchecked_Access
2122       then
2123          raise Program_Error;
2124       end if;
2125
2126       if Position.Container = null
2127         or else Position.Index > Container.Last
2128       then
2129          Last := Container.Last;
2130       else
2131          Last := Position.Index;
2132       end if;
2133
2134       for Indx in reverse Index_Type'First .. Last loop
2135          if Container.Elements (Indx) /= null
2136            and then Container.Elements (Indx).all = Item
2137          then
2138             return (Container'Unchecked_Access, Indx);
2139          end if;
2140       end loop;
2141
2142       return No_Element;
2143    end Reverse_Find;
2144
2145    ------------------------
2146    -- Reverse_Find_Index --
2147    ------------------------
2148
2149    function Reverse_Find_Index
2150      (Container : Vector;
2151       Item      : Element_Type;
2152       Index     : Index_Type := Index_Type'Last) return Extended_Index
2153    is
2154       Last : Index_Type'Base;
2155
2156    begin
2157       if Index > Container.Last then
2158          Last := Container.Last;
2159       else
2160          Last := Index;
2161       end if;
2162
2163       for Indx in reverse Index_Type'First .. Last loop
2164          if Container.Elements (Indx) /= null
2165            and then Container.Elements (Indx).all = Item
2166          then
2167             return Indx;
2168          end if;
2169       end loop;
2170
2171       return No_Index;
2172    end Reverse_Find_Index;
2173
2174    ---------------------
2175    -- Reverse_Iterate --
2176    ---------------------
2177
2178    procedure Reverse_Iterate
2179      (Container : Vector;
2180       Process   : not null access procedure (Position : in Cursor))
2181    is
2182       V : Vector renames Container'Unrestricted_Access.all;
2183       B : Natural renames V.Busy;
2184
2185    begin
2186       B := B + 1;
2187
2188       begin
2189          for Indx in reverse Index_Type'First .. Container.Last loop
2190             Process (Cursor'(Container'Unchecked_Access, Indx));
2191          end loop;
2192       exception
2193          when others =>
2194             B := B - 1;
2195             raise;
2196       end;
2197
2198       B := B - 1;
2199    end Reverse_Iterate;
2200
2201    ----------------
2202    -- Set_Length --
2203    ----------------
2204
2205    procedure Set_Length
2206      (Container : in out Vector;
2207       Length    : Count_Type)
2208    is
2209       N : constant Count_Type := Indefinite_Vectors.Length (Container);
2210
2211    begin
2212       if Length = N then
2213          return;
2214       end if;
2215
2216       if Container.Busy > 0 then
2217          raise Program_Error;
2218       end if;
2219
2220       if Length < N then
2221          for Index in 1 .. N - Length loop
2222             declare
2223                J : constant Index_Type := Container.Last;
2224                X : Element_Access := Container.Elements (J);
2225
2226             begin
2227                Container.Elements (J) := null;
2228                Container.Last := J - 1;
2229                Free (X);
2230             end;
2231          end loop;
2232
2233          return;
2234       end if;
2235
2236       if Length > Capacity (Container) then
2237          Reserve_Capacity (Container, Capacity => Length);
2238       end if;
2239
2240       declare
2241          Last_As_Int : constant Int'Base :=
2242                          Int (Index_Type'First) + Int (Length) - 1;
2243
2244       begin
2245          Container.Last := Index_Type (Last_As_Int);
2246       end;
2247    end Set_Length;
2248
2249    ----------
2250    -- Swap --
2251    ----------
2252
2253    procedure Swap
2254      (Container : in out Vector;
2255       I, J      : Index_Type)
2256    is
2257    begin
2258       if I > Container.Last
2259         or else J > Container.Last
2260       then
2261          raise Constraint_Error;
2262       end if;
2263
2264       if I = J then
2265          return;
2266       end if;
2267
2268       if Container.Lock > 0 then
2269          raise Program_Error;
2270       end if;
2271
2272       declare
2273          EI : Element_Access renames Container.Elements (I);
2274          EJ : Element_Access renames Container.Elements (J);
2275
2276          EI_Copy : constant Element_Access := EI;
2277
2278       begin
2279          EI := EJ;
2280          EJ := EI_Copy;
2281       end;
2282    end Swap;
2283
2284    procedure Swap
2285      (Container : in out Vector;
2286       I, J      : Cursor)
2287    is
2288    begin
2289       if I.Container = null
2290         or else J.Container = null
2291       then
2292          raise Constraint_Error;
2293       end if;
2294
2295       if I.Container /= Container'Unrestricted_Access
2296         or else J.Container /= Container'Unrestricted_Access
2297       then
2298          raise Program_Error;
2299       end if;
2300
2301       Swap (Container, I.Index, J.Index);
2302    end Swap;
2303
2304    ---------------
2305    -- To_Cursor --
2306    ---------------
2307
2308    function To_Cursor
2309      (Container : Vector;
2310       Index     : Extended_Index) return Cursor
2311    is
2312    begin
2313       if Index not in Index_Type'First .. Container.Last then
2314          return No_Element;
2315       end if;
2316
2317       return Cursor'(Container'Unchecked_Access, Index);
2318    end To_Cursor;
2319
2320    --------------
2321    -- To_Index --
2322    --------------
2323
2324    function To_Index (Position : Cursor) return Extended_Index is
2325    begin
2326       if Position.Container = null then
2327          return No_Index;
2328       end if;
2329
2330       if Position.Index <= Position.Container.Last then
2331          return Position.Index;
2332       end if;
2333
2334       return No_Index;
2335    end To_Index;
2336
2337    ---------------
2338    -- To_Vector --
2339    ---------------
2340
2341    function To_Vector (Length : Count_Type) return Vector is
2342    begin
2343       if Length = 0 then
2344          return Empty_Vector;
2345       end if;
2346
2347       declare
2348          First       : constant Int := Int (Index_Type'First);
2349          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2350          Last        : Index_Type;
2351          Elements    : Elements_Access;
2352
2353       begin
2354          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2355             raise Constraint_Error;
2356          end if;
2357
2358          Last := Index_Type (Last_As_Int);
2359          Elements := new Elements_Type (Index_Type'First .. Last);
2360
2361          return (Controlled with Elements, Last, 0, 0);
2362       end;
2363    end To_Vector;
2364
2365    function To_Vector
2366      (New_Item : Element_Type;
2367       Length   : Count_Type) return Vector
2368    is
2369    begin
2370       if Length = 0 then
2371          return Empty_Vector;
2372       end if;
2373
2374       declare
2375          First       : constant Int := Int (Index_Type'First);
2376          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2377          Last        : Index_Type'Base;
2378          Elements    : Elements_Access;
2379
2380       begin
2381          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2382             raise Constraint_Error;
2383          end if;
2384
2385          Last := Index_Type (Last_As_Int);
2386          Elements := new Elements_Type (Index_Type'First .. Last);
2387
2388          Last := Index_Type'First;
2389
2390          begin
2391             loop
2392                Elements (Last) := new Element_Type'(New_Item);
2393                exit when Last = Elements'Last;
2394                Last := Last + 1;
2395             end loop;
2396          exception
2397             when others =>
2398                for J in Index_Type'First .. Last - 1 loop
2399                   Free (Elements (J));
2400                end loop;
2401
2402                Free (Elements);
2403                raise;
2404          end;
2405
2406          return (Controlled with Elements, Last, 0, 0);
2407       end;
2408    end To_Vector;
2409
2410    --------------------
2411    -- Update_Element --
2412    --------------------
2413
2414    procedure Update_Element
2415      (Container : in out Vector;
2416       Index     : Index_Type;
2417       Process   : not null access procedure (Element : in out Element_Type))
2418    is
2419       B : Natural renames Container.Busy;
2420       L : Natural renames Container.Lock;
2421
2422    begin
2423       if Index > Container.Last then
2424          raise Constraint_Error;
2425       end if;
2426
2427       if Container.Elements (Index) = null then
2428          raise Constraint_Error;
2429       end if;
2430
2431       B := B + 1;
2432       L := L + 1;
2433
2434       begin
2435          Process (Container.Elements (Index).all);
2436       exception
2437          when others =>
2438             L := L - 1;
2439             B := B - 1;
2440             raise;
2441       end;
2442
2443       L := L - 1;
2444       B := B - 1;
2445    end Update_Element;
2446
2447    procedure Update_Element
2448      (Container : in out Vector;
2449       Position  : Cursor;
2450       Process   : not null access procedure (Element : in out Element_Type))
2451    is
2452    begin
2453       if Position.Container = null then
2454          raise Constraint_Error;
2455       end if;
2456
2457       if Position.Container /= Container'Unrestricted_Access then
2458          raise Program_Error;
2459       end if;
2460
2461       Update_Element (Container, Position.Index, Process);
2462    end Update_Element;
2463
2464    -----------
2465    -- Write --
2466    -----------
2467
2468    procedure Write
2469      (Stream    : access Root_Stream_Type'Class;
2470       Container : Vector)
2471    is
2472       N : constant Count_Type := Length (Container);
2473
2474    begin
2475       Count_Type'Base'Write (Stream, N);
2476
2477       if N = 0 then
2478          return;
2479       end if;
2480
2481       declare
2482          E : Elements_Type renames Container.Elements.all;
2483
2484       begin
2485          for Indx in Index_Type'First .. Container.Last loop
2486
2487             --  There's another way to do this.  Instead a separate
2488             --  Boolean for each element, you could write a Boolean
2489             --  followed by a count of how many nulls or non-nulls
2490             --  follow in the array.
2491
2492             if E (Indx) = null then
2493                Boolean'Write (Stream, False);
2494             else
2495                Boolean'Write (Stream, True);
2496                Element_Type'Output (Stream, E (Indx).all);
2497             end if;
2498          end loop;
2499       end;
2500    end Write;
2501
2502    procedure Write
2503      (Stream   : access Root_Stream_Type'Class;
2504       Position : Cursor)
2505    is
2506    begin
2507       raise Program_Error;
2508    end Write;
2509
2510 end Ada.Containers.Indefinite_Vectors;