gcc/ada/libgnat/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-2018, 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             --  If K + 2 is greater than N, then Buf (K + 1) cannot be a LM
 124             --  character from the source file, as the call to fgets copied at
 125             --  most N - 1 characters. Otherwise, either LM is a character from
 126             --  the source file and then Buf (K + 2) should be 0, or LM is a
 127             --  character put in Buf by memset and then Buf (K) is the 0 put in
 128             --  by fgets. In both cases where LM does not come from the source
 129             --  file, compensate.
 130
 131             if K + 2 > N or else Buf (K + 2) /= ASCII.NUL then
 132
 133                --  Incomplete last line, so remove the extra 0
 134
 135                pragma Assert (Buf (K) = ASCII.NUL);
 136                K := K - 1;
 137             end if;
 138
 139             memcpy (Item (Last + 1)'Address,
 140                     Buf (1)'Address, size_t (K));
 141             Last := Last + K;
 142          end;
 143
 144          return 0;
 145       end if;
 146    end Get_Chunk;
 147
 148 --  Start of processing for Get_Line
 149
 150 begin
 151    FIO.Check_Read_Status (AP (File));
 152
 153    --  Set Last to Item'First - 1 when no characters are read, as mandated by
 154    --  Ada RM. In the case where Item'First is negative or null, this results
 155    --  in Constraint_Error being raised.
 156
 157    Last := Item'First - 1;
 158
 159    --  Immediate exit for null string, this is a case in which we do not
 160    --  need to test for end of file and we do not skip a line mark under
 161    --  any circumstances.
 162
 163    if Item'First > Item'Last then
 164       return;
 165    end if;
 166
 167    N := Item'Last - Item'First + 1;
 168
 169    --  Here we have at least one character, if we are immediately before
 170    --  a line mark, then we will just skip past it storing no characters.
 171
 172    if File.Before_LM then
 173       File.Before_LM := False;
 174       File.Before_LM_PM := False;
 175
 176    --  Otherwise we need to read some characters
 177
 178    else
 179       while N >= Chunk_Size loop
 180          if Get_Chunk (Chunk_Size) = 0 then
 181             N := 0;
 182          else
 183             N := N - Chunk_Size + 1;
 184          end if;
 185       end loop;
 186
 187       if N > 1 then
 188          N := Get_Chunk (N);
 189       end if;
 190
 191       --  Almost there, only a little bit more to read
 192
 193       if N = 1 then
 194          ch := Getc (File);
 195
 196          --  If we get EOF after already reading data, this is an incomplete
 197          --  last line, in which case no End_Error should be raised.
 198
 199          if ch = EOF then
 200             if Last < Item'First then
 201                raise End_Error;
 202
 203             else  --  All done
 204                return;
 205             end if;
 206
 207          elsif ch /= LM then
 208
 209             --  Buffer really is full without having seen LM, update col
 210
 211             Last := Last + 1;
 212             Item (Last) := Character'Val (ch);
 213             File.Col := File.Col + Count (Last - Item'First + 1);
 214             return;
 215          end if;
 216       end if;
 217    end if;
 218
 219    --  We have skipped past, but not stored, a line mark. Skip following
 220    --  page mark if one follows, but do not do this for a non-regular file
 221    --  (since otherwise we get annoying wait for an extra character)
 222
 223    File.Line := File.Line + 1;
 224    File.Col := 1;
 225
 226    if File.Before_LM_PM then
 227       File.Line := 1;
 228       File.Before_LM_PM := False;
 229       File.Page := File.Page + 1;
 230
 231    elsif File.Is_Regular_File then
 232       ch := Getc (File);
 233
 234       if ch = PM and then File.Is_Regular_File then
 235          File.Line := 1;
 236          File.Page := File.Page + 1;
 237       else
 238          Ungetc (ch, File);
 239       end if;
 240    end if;
 241 end Get_Line;