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