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