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