gcc/ada/a-coinve.adb

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