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