gcc/ada/a-cofove.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --         A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2010-2014, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Ada.Containers.Generic_Array_Sort;
  29 with Ada.Unchecked_Deallocation;
  30
  31 with System; use type System.Address;
  32
  33 package body Ada.Containers.Formal_Vectors with
  34   SPARK_Mode => Off
  35 is
  36    pragma Annotate (CodePeer, Skip_Analysis);
  37
  38    Growth_Factor : constant := 2;
  39    --  When growing a container, multiply current capacity by this. Doubling
  40    --  leads to amortized linear-time copying.
  41
  42    type Int is range System.Min_Int .. System.Max_Int;
  43    type UInt is mod System.Max_Binary_Modulus;
  44
  45    procedure Free is
  46       new Ada.Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr);
  47
  48    type Maximal_Array_Ptr is access all Elements_Array (Array_Index)
  49      with Storage_Size => 0;
  50    type Maximal_Array_Ptr_Const is access constant Elements_Array (Array_Index)
  51        with Storage_Size => 0;
  52
  53    function Elems (Container : in out Vector) return Maximal_Array_Ptr;
  54    function Elemsc
  55      (Container : Vector) return Maximal_Array_Ptr_Const;
  56    --  Returns a pointer to the Elements array currently in use -- either
  57    --  Container.Elements_Ptr or a pointer to Container.Elements. We work with
  58    --  pointers to a bogus array subtype that is constrained with the maximum
  59    --  possible bounds. This means that the pointer is a thin pointer. This is
  60    --  necessary because 'Unrestricted_Access doesn't work when it produces
  61    --  access-to-unconstrained and is returned from a function.
  62    --
  63    --  Note that this is dangerous: make sure calls to this use an indexed
  64    --  component or slice that is within the bounds 1 .. Length (Container).
  65
  66    function Get_Element
  67      (Container : Vector;
  68       Position  : Capacity_Range) return Element_Type;
  69
  70    ---------
  71    -- "=" --
  72    ---------
  73
  74    function "=" (Left, Right : Vector) return Boolean is
  75    begin
  76       if Left'Address = Right'Address then
  77          return True;
  78       end if;
  79
  80       if Length (Left) /= Length (Right) then
  81          return False;
  82       end if;
  83
  84       for J in 1 .. Length (Left) loop
  85          if Get_Element (Left, J) /= Get_Element (Right, J) then
  86             return False;
  87          end if;
  88       end loop;
  89
  90       return True;
  91    end "=";
  92
  93    ------------
  94    -- Append --
  95    ------------
  96
  97    procedure Append (Container : in out Vector; New_Item : Vector) is
  98    begin
  99       for X in First_Index (New_Item) .. Last_Index (New_Item)  loop
 100          Append (Container, Element (New_Item, X));
 101       end loop;
 102    end Append;
 103
 104    procedure Append
 105      (Container : in out Vector;
 106       New_Item  : Element_Type)
 107    is
 108       New_Length : constant UInt := UInt (Length (Container) + 1);
 109    begin
 110       if not Bounded and then
 111         Capacity (Container) < Capacity_Range (New_Length)
 112       then
 113          Reserve_Capacity
 114            (Container,
 115             Capacity_Range'Max (Capacity (Container) * Growth_Factor,
 116                                 Capacity_Range (New_Length)));
 117       end if;
 118
 119       if Container.Last = Index_Type'Last then
 120          raise Constraint_Error with "vector is already at its maximum length";
 121       end if;
 122
 123       --  TODO: should check whether length > max capacity (cnt_t'last)  ???
 124
 125       Container.Last := Container.Last + 1;
 126       Elems (Container) (Length (Container)) := New_Item;
 127    end Append;
 128
 129    ------------
 130    -- Assign --
 131    ------------
 132
 133    procedure Assign (Target : in out Vector; Source : Vector) is
 134       LS : constant Capacity_Range := Length (Source);
 135
 136    begin
 137       if Target'Address = Source'Address then
 138          return;
 139       end if;
 140
 141       if Bounded and then Target.Capacity < LS then
 142          raise Constraint_Error;
 143       end if;
 144
 145       Clear (Target);
 146       Append (Target, Source);
 147    end Assign;
 148
 149    --------------
 150    -- Capacity --
 151    --------------
 152
 153    function Capacity (Container : Vector) return Capacity_Range is
 154    begin
 155       return (if Container.Elements_Ptr = null
 156               then Container.Elements'Length
 157               else Container.Elements_Ptr.all'Length);
 158    end Capacity;
 159
 160    -----------
 161    -- Clear --
 162    -----------
 163
 164    procedure Clear (Container : in out Vector) is
 165    begin
 166       Container.Last := No_Index;
 167
 168       --  Free element, note that this is OK if Elements_Ptr is null
 169
 170       Free (Container.Elements_Ptr);
 171    end Clear;
 172
 173    --------------
 174    -- Contains --
 175    --------------
 176
 177    function Contains
 178      (Container : Vector;
 179       Item      : Element_Type) return Boolean
 180    is
 181    begin
 182       return Find_Index (Container, Item) /= No_Index;
 183    end Contains;
 184
 185    ----------
 186    -- Copy --
 187    ----------
 188
 189    function Copy
 190      (Source   : Vector;
 191       Capacity : Capacity_Range := 0) return Vector
 192    is
 193       LS : constant Capacity_Range := Length (Source);
 194       C  : Capacity_Range;
 195
 196    begin
 197       if Capacity = 0 then
 198          C := LS;
 199       elsif Capacity >= LS then
 200          C := Capacity;
 201       else
 202          raise Capacity_Error;
 203       end if;
 204
 205       return Target : Vector (C) do
 206          Elems (Target) (1 .. LS) := Elemsc (Source) (1 .. LS);
 207          Target.Last := Source.Last;
 208       end return;
 209    end Copy;
 210
 211    ---------------------
 212    -- Current_To_Last --
 213    ---------------------
 214
 215    function Current_To_Last
 216      (Container : Vector;
 217       Current   : Index_Type) return Vector
 218    is
 219    begin
 220       return Result : Vector (Count_Type (Container.Last - Current + 1))
 221       do
 222          for X in Current .. Container.Last loop
 223             Append (Result, Element (Container, X));
 224          end loop;
 225       end return;
 226    end Current_To_Last;
 227
 228    -----------------
 229    -- Delete_Last --
 230    -----------------
 231
 232    procedure Delete_Last
 233      (Container : in out Vector)
 234    is
 235       Count : constant Capacity_Range := 1;
 236       Index : Int'Base;
 237
 238    begin
 239       Index := Int'Base (Container.Last) - Int'Base (Count);
 240
 241       if Index < Index_Type'Pos (Index_Type'First) then
 242          Container.Last := No_Index;
 243       else
 244          Container.Last := Index_Type (Index);
 245       end if;
 246    end Delete_Last;
 247
 248    -------------
 249    -- Element --
 250    -------------
 251
 252    function Element
 253      (Container : Vector;
 254       Index     : Index_Type) return Element_Type
 255    is
 256    begin
 257       if Index > Container.Last then
 258          raise Constraint_Error with "Index is out of range";
 259       end if;
 260
 261       declare
 262          II : constant Int'Base := Int (Index) - Int (No_Index);
 263          I  : constant Capacity_Range := Capacity_Range (II);
 264       begin
 265          return Get_Element (Container, I);
 266       end;
 267    end Element;
 268
 269    --------------
 270    -- Elements --
 271    --------------
 272
 273    function Elems (Container : in out Vector) return Maximal_Array_Ptr is
 274    begin
 275       return (if Container.Elements_Ptr = null
 276               then Container.Elements'Unrestricted_Access
 277               else Container.Elements_Ptr.all'Unrestricted_Access);
 278    end Elems;
 279
 280    function Elemsc
 281      (Container : Vector) return Maximal_Array_Ptr_Const is
 282    begin
 283       return (if Container.Elements_Ptr = null
 284               then Container.Elements'Unrestricted_Access
 285               else Container.Elements_Ptr.all'Unrestricted_Access);
 286    end Elemsc;
 287
 288    ----------------
 289    -- Find_Index --
 290    ----------------
 291
 292    function Find_Index
 293      (Container : Vector;
 294       Item      : Element_Type;
 295       Index     : Index_Type := Index_Type'First) return Extended_Index
 296    is
 297       K    : Capacity_Range;
 298       Last : constant Index_Type := Last_Index (Container);
 299
 300    begin
 301       K := Capacity_Range (Int (Index) - Int (No_Index));
 302       for Indx in Index .. Last loop
 303          if Get_Element (Container, K) = Item then
 304             return Indx;
 305          end if;
 306
 307          K := K + 1;
 308       end loop;
 309
 310       return No_Index;
 311    end Find_Index;
 312
 313    -------------------
 314    -- First_Element --
 315    -------------------
 316
 317    function First_Element (Container : Vector) return Element_Type is
 318    begin
 319       if Is_Empty (Container) then
 320          raise Constraint_Error with "Container is empty";
 321       else
 322          return Get_Element (Container, 1);
 323       end if;
 324    end First_Element;
 325
 326    -----------------
 327    -- First_Index --
 328    -----------------
 329
 330    function First_Index (Container : Vector) return Index_Type is
 331       pragma Unreferenced (Container);
 332    begin
 333       return Index_Type'First;
 334    end First_Index;
 335
 336    -----------------------
 337    -- First_To_Previous --
 338    -----------------------
 339
 340    function First_To_Previous
 341      (Container : Vector;
 342       Current   : Index_Type) return Vector
 343    is
 344    begin
 345       return Result : Vector
 346         (Count_Type (Current - First_Index (Container)))
 347       do
 348          for X in First_Index (Container) .. Current - 1 loop
 349             Append (Result, Element (Container, X));
 350          end loop;
 351       end return;
 352    end First_To_Previous;
 353
 354    ---------------------
 355    -- Generic_Sorting --
 356    ---------------------
 357
 358    package body Generic_Sorting is
 359
 360       ---------------
 361       -- Is_Sorted --
 362       ---------------
 363
 364       function Is_Sorted (Container : Vector) return Boolean is
 365          L : constant Capacity_Range := Length (Container);
 366       begin
 367          for J in 1 .. L - 1 loop
 368             if Get_Element (Container, J + 1) <
 369                Get_Element (Container, J)
 370             then
 371                return False;
 372             end if;
 373          end loop;
 374
 375          return True;
 376       end Is_Sorted;
 377
 378       ----------
 379       -- Sort --
 380       ----------
 381
 382       procedure Sort (Container : in out Vector)
 383       is
 384          procedure Sort is
 385            new Generic_Array_Sort
 386              (Index_Type   => Array_Index,
 387               Element_Type => Element_Type,
 388               Array_Type   => Elements_Array,
 389               "<"          => "<");
 390
 391          Len : constant Capacity_Range := Length (Container);
 392       begin
 393          if Container.Last <= Index_Type'First then
 394             return;
 395          else
 396             Sort (Elems (Container) (1 .. Len));
 397          end if;
 398       end Sort;
 399
 400    end Generic_Sorting;
 401
 402    -----------------
 403    -- Get_Element --
 404    -----------------
 405
 406    function Get_Element
 407      (Container : Vector;
 408       Position  : Capacity_Range) return Element_Type
 409    is
 410    begin
 411       return Elemsc (Container) (Position);
 412    end Get_Element;
 413
 414    -----------------
 415    -- Has_Element --
 416    -----------------
 417
 418    function Has_Element
 419      (Container : Vector; Position : Extended_Index) return Boolean is
 420    begin
 421       return Position in First_Index (Container) .. Last_Index (Container);
 422    end Has_Element;
 423
 424    --------------
 425    -- Is_Empty --
 426    --------------
 427
 428    function Is_Empty (Container : Vector) return Boolean is
 429    begin
 430       return Last_Index (Container) < Index_Type'First;
 431    end Is_Empty;
 432
 433    ------------------
 434    -- Last_Element --
 435    ------------------
 436
 437    function Last_Element (Container : Vector) return Element_Type is
 438    begin
 439       if Is_Empty (Container) then
 440          raise Constraint_Error with "Container is empty";
 441       else
 442          return Get_Element (Container, Length (Container));
 443       end if;
 444    end Last_Element;
 445
 446    ----------------
 447    -- Last_Index --
 448    ----------------
 449
 450    function Last_Index (Container : Vector) return Extended_Index is
 451    begin
 452       return Container.Last;
 453    end Last_Index;
 454
 455    ------------
 456    -- Length --
 457    ------------
 458
 459    function Length (Container : Vector) return Capacity_Range is
 460       L : constant Int := Int (Last_Index (Container));
 461       F : constant Int := Int (Index_Type'First);
 462       N : constant Int'Base := L - F + 1;
 463    begin
 464       return Capacity_Range (N);
 465    end Length;
 466
 467    ---------------------
 468    -- Replace_Element --
 469    ---------------------
 470
 471    procedure Replace_Element
 472      (Container : in out Vector;
 473       Index     : Index_Type;
 474       New_Item  : Element_Type)
 475    is
 476    begin
 477       if Index > Container.Last then
 478          raise Constraint_Error with "Index is out of range";
 479       end if;
 480
 481       declare
 482          II : constant Int'Base := Int (Index) - Int (No_Index);
 483          I  : constant Capacity_Range := Capacity_Range (II);
 484       begin
 485          Elems (Container) (I) := New_Item;
 486       end;
 487    end Replace_Element;
 488
 489    ----------------------
 490    -- Reserve_Capacity --
 491    ----------------------
 492
 493    procedure Reserve_Capacity
 494      (Container : in out Vector;
 495       Capacity  : Capacity_Range)
 496    is
 497    begin
 498       if Bounded then
 499          if Capacity > Container.Capacity then
 500             raise Constraint_Error with "Capacity is out of range";
 501          end if;
 502       else
 503          if Capacity > Formal_Vectors.Capacity (Container) then
 504             declare
 505                New_Elements : constant Elements_Array_Ptr :=
 506                                 new Elements_Array (1 .. Capacity);
 507                L            : constant Capacity_Range := Length (Container);
 508             begin
 509                New_Elements (1 .. L) := Elemsc (Container) (1 .. L);
 510                Free (Container.Elements_Ptr);
 511                Container.Elements_Ptr := New_Elements;
 512             end;
 513          end if;
 514       end if;
 515    end Reserve_Capacity;
 516
 517    ----------------------
 518    -- Reverse_Elements --
 519    ----------------------
 520
 521    procedure Reverse_Elements (Container : in out Vector) is
 522    begin
 523       if Length (Container) <= 1 then
 524          return;
 525       end if;
 526
 527       declare
 528          I, J : Capacity_Range;
 529          E    : Elements_Array renames
 530                   Elems (Container) (1 .. Length (Container));
 531
 532       begin
 533          I := 1;
 534          J := Length (Container);
 535          while I < J loop
 536             declare
 537                EI : constant Element_Type := E (I);
 538             begin
 539                E (I) := E (J);
 540                E (J) := EI;
 541             end;
 542
 543             I := I + 1;
 544             J := J - 1;
 545          end loop;
 546       end;
 547    end Reverse_Elements;
 548
 549    ------------------------
 550    -- Reverse_Find_Index --
 551    ------------------------
 552
 553    function Reverse_Find_Index
 554      (Container : Vector;
 555       Item      : Element_Type;
 556       Index     : Index_Type := Index_Type'Last) return Extended_Index
 557    is
 558       Last : Index_Type'Base;
 559       K    : Capacity_Range;
 560
 561    begin
 562       if Index > Last_Index (Container) then
 563          Last := Last_Index (Container);
 564       else
 565          Last := Index;
 566       end if;
 567
 568       K := Capacity_Range (Int (Last) - Int (No_Index));
 569       for Indx in reverse Index_Type'First .. Last loop
 570          if Get_Element (Container, K) = Item then
 571             return Indx;
 572          end if;
 573
 574          K := K - 1;
 575       end loop;
 576
 577       return No_Index;
 578    end Reverse_Find_Index;
 579
 580    ----------
 581    -- Swap --
 582    ----------
 583
 584    procedure Swap (Container : in out Vector; I, J : Index_Type) is
 585    begin
 586       if I > Container.Last then
 587          raise Constraint_Error with "I index is out of range";
 588       end if;
 589
 590       if J > Container.Last then
 591          raise Constraint_Error with "J index is out of range";
 592       end if;
 593
 594       if I = J then
 595          return;
 596       end if;
 597
 598       declare
 599          II : constant Int'Base := Int (I) - Int (No_Index);
 600          JJ : constant Int'Base := Int (J) - Int (No_Index);
 601
 602          EI : Element_Type renames Elems (Container) (Capacity_Range (II));
 603          EJ : Element_Type renames Elems (Container) (Capacity_Range (JJ));
 604
 605          EI_Copy : constant Element_Type := EI;
 606
 607       begin
 608          EI := EJ;
 609          EJ := EI_Copy;
 610       end;
 611    end Swap;
 612
 613    ---------------
 614    -- To_Vector --
 615    ---------------
 616
 617    function To_Vector
 618      (New_Item : Element_Type;
 619       Length   : Capacity_Range) return Vector
 620    is
 621    begin
 622       if Length = 0 then
 623          return Empty_Vector;
 624       end if;
 625
 626       declare
 627          First       : constant Int := Int (Index_Type'First);
 628          Last_As_Int : constant Int'Base := First + Int (Length) - 1;
 629          Last        : Index_Type;
 630
 631       begin
 632          if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
 633             raise Constraint_Error with "Length is out of range";  -- ???
 634          end if;
 635
 636          Last := Index_Type (Last_As_Int);
 637
 638          return (Capacity     => Length,
 639                  Last         => Last,
 640                  Elements_Ptr => <>,
 641                  Elements     => (others => New_Item));
 642       end;
 643    end To_Vector;
 644
 645 end Ada.Containers.Formal_Vectors;