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