gcc/ada/a-tigeli.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                 A D A . T E X T _ I O . G E T _ L I N E                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-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 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  The implementation of Ada.Text_IO.Get_Line is split into a subunit so that
  33 --  different implementations can be used on different systems. This is the
  34 --  standard implementation (it uses low level features not suitable for use
  35 --  on virtual machines).
  36
  37 with System;                  use System;
  38 with System.Storage_Elements; use System.Storage_Elements;
  39
  40 separate (Ada.Text_IO)
  41 procedure Get_Line
  42   (File : File_Type;
  43    Item : out String;
  44    Last : out Natural)
  45 is
  46    Chunk_Size : constant := 80;
  47    --  We read into a fixed size auxiliary buffer. Because this buffer
  48    --  needs to be pre-initialized, there is a trade-off between size and
  49    --  speed. Experiments find returns are diminishing after 50 and this
  50    --  size allows most lines to be processed with a single read.
  51
  52    ch : int;
  53    N  : Natural;
  54
  55    procedure memcpy (s1, s2 : chars; n : size_t);
  56    pragma Import (C, memcpy);
  57
  58    function memchr (s : chars; ch : int; n : size_t) return chars;
  59    pragma Import (C, memchr);
  60
  61    procedure memset (b : chars; ch : int; n : size_t);
  62    pragma Import (C, memset);
  63
  64    function Get_Chunk (N : Positive) return Natural;
  65    --  Reads at most N - 1 characters into Item (Last + 1 .. Item'Last),
  66    --  updating Last. Raises End_Error if nothing was read (End_Of_File).
  67    --  Returns number of characters still to read (either 0 or 1) in
  68    --  case of success.
  69
  70    ---------------
  71    -- Get_Chunk --
  72    ---------------
  73
  74    function Get_Chunk (N : Positive) return Natural is
  75       Buf : String (1 .. Chunk_Size);
  76       S   : constant chars := Buf (1)'Address;
  77       P   : chars;
  78
  79    begin
  80       if N = 1 then
  81          return N;
  82       end if;
  83
  84       memset (S, 10, size_t (N));
  85
  86       if fgets (S, N, File.Stream) = Null_Address then
  87          if ferror (File.Stream) /= 0 then
  88             raise Device_Error;
  89
  90          --  If incomplete last line, pretend we found a LM
  91
  92          elsif Last >= Item'First then
  93             return 0;
  94
  95          else
  96             raise End_Error;
  97          end if;
  98       end if;
  99
 100       P := memchr (S, LM, size_t (N));
 101
 102       --  If no LM is found, the buffer got filled without reading a new
 103       --  line. Otherwise, the LM is either one from the input, or else one
 104       --  from the initialization, which means an incomplete end-of-line was
 105       --  encountered. Only in first case the LM will be followed by a 0.
 106
 107       if P = Null_Address then
 108          pragma Assert (Buf (N) = ASCII.NUL);
 109          memcpy (Item (Last + 1)'Address,
 110                  Buf (1)'Address, size_t (N - 1));
 111          Last := Last + N - 1;
 112
 113          return 1;
 114
 115       else
 116          --  P points to the LM character. Set K so Buf (K) is the character
 117          --  right before.
 118
 119          declare
 120             K : Natural := Natural (P - S);
 121
 122          begin
 123             --  Now Buf (K + 2) should be 0, or otherwise Buf (K) is the 0
 124             --  put in by fgets, so compensate.
 125
 126             if K + 2 > Buf'Last or else Buf (K + 2) /= ASCII.NUL then
 127
 128                --  Incomplete last line, so remove the extra 0
 129
 130                pragma Assert (Buf (K) = ASCII.NUL);
 131                K := K - 1;
 132             end if;
 133
 134             memcpy (Item (Last + 1)'Address,
 135                     Buf (1)'Address, size_t (K));
 136             Last := Last + K;
 137          end;
 138
 139          return 0;
 140       end if;
 141    end Get_Chunk;
 142
 143 --  Start of processing for Get_Line
 144
 145 begin
 146    FIO.Check_Read_Status (AP (File));
 147
 148    --  Immediate exit for null string, this is a case in which we do not
 149    --  need to test for end of file and we do not skip a line mark under
 150    --  any circumstances.
 151
 152    if Item'First > Item'Last then
 153       return;
 154    end if;
 155
 156    N := Item'Last - Item'First + 1;
 157
 158    Last := Item'First - 1;
 159
 160    --  Here we have at least one character, if we are immediately before
 161    --  a line mark, then we will just skip past it storing no characters.
 162
 163    if File.Before_LM then
 164       File.Before_LM := False;
 165       File.Before_LM_PM := False;
 166
 167    --  Otherwise we need to read some characters
 168
 169    else
 170       while N >= Chunk_Size loop
 171          if Get_Chunk (Chunk_Size) = 0 then
 172             N := 0;
 173          else
 174             N := N - Chunk_Size + 1;
 175          end if;
 176       end loop;
 177
 178       if N > 1 then
 179          N := Get_Chunk (N);
 180       end if;
 181
 182       --  Almost there, only a little bit more to read
 183
 184       if N = 1 then
 185          ch := Getc (File);
 186
 187          --  If we get EOF after already reading data, this is an incomplete
 188          --  last line, in which case no End_Error should be raised.
 189
 190          if ch = EOF and then Last < Item'First then
 191             raise End_Error;
 192
 193          elsif ch /= LM then
 194
 195             --  Buffer really is full without having seen LM, update col
 196
 197             Last := Last + 1;
 198             Item (Last) := Character'Val (ch);
 199             File.Col := File.Col + Count (Last - Item'First + 1);
 200             return;
 201          end if;
 202       end if;
 203    end if;
 204
 205    --  We have skipped past, but not stored, a line mark. Skip following
 206    --  page mark if one follows, but do not do this for a non-regular file
 207    --  (since otherwise we get annoying wait for an extra character)
 208
 209    File.Line := File.Line + 1;
 210    File.Col := 1;
 211
 212    if File.Before_LM_PM then
 213       File.Line := 1;
 214       File.Before_LM_PM := False;
 215       File.Page := File.Page + 1;
 216
 217    elsif File.Is_Regular_File then
 218       ch := Getc (File);
 219
 220       if ch = PM and then File.Is_Regular_File then
 221          File.Line := 1;
 222          File.Page := File.Page + 1;
 223       else
 224          Ungetc (ch, File);
 225       end if;
 226    end if;
 227 end Get_Line;