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