gcc/ada/a-tigeli.adb

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