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
37with System;                  use System;
38with System.Storage_Elements; use System.Storage_Elements;
39
40separate (Ada.Text_IO)
41procedure Get_Line
42  (File : File_Type;
43   Item : out String;
44   Last : out Natural)
45is
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
150begin
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;
241end Get_Line;
242