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