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