1 /* Copyright (C) 2002-2018 Free Software Foundation, Inc.
2 Contributed by Andy Vaught and Janne Blomqvist
3
4 This file is part of the GNU Fortran runtime library (libgfortran).
5
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 3, or (at your option)
9 any later version.
10
11 Libgfortran is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 Under Section 7 of GPL version 3, you are granted additional
17 permissions described in the GCC Runtime Library Exception, version
18 3.1, as published by the Free Software Foundation.
19
20 You should have received a copy of the GNU General Public License and
21 a copy of the GCC Runtime Library Exception along with this program;
22 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
23 <http://www.gnu.org/licenses/>. */
24
25 #include "io.h"
26 #include "fbuf.h"
27 #include "unix.h"
28 #include <string.h>
29
30 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
31 ENDFILE, and REWIND as well as the FLUSH statement. */
32
33
34 /* formatted_backspace(fpp, u)-- Move the file back one line. The
35 current position is after the newline that terminates the previous
36 record, and we have to sift backwards to find the newline before
37 that or the start of the file, whichever comes first. */
38
39 #define READ_CHUNK 4096
40
41 static void
formatted_backspace(st_parameter_filepos * fpp,gfc_unit * u)42 formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
43 {
44 gfc_offset base;
45 char p[READ_CHUNK];
46 ssize_t n;
47
48 base = stell (u->s) - 1;
49
50 do
51 {
52 n = (base < READ_CHUNK) ? base : READ_CHUNK;
53 base -= n;
54 if (sseek (u->s, base, SEEK_SET) < 0)
55 goto io_error;
56 if (sread (u->s, p, n) != n)
57 goto io_error;
58
59 /* We have moved backwards from the current position, it should
60 not be possible to get a short read. Because it is not
61 clear what to do about such thing, we ignore the possibility. */
62
63 /* There is no memrchr() in the C library, so we have to do it
64 ourselves. */
65
66 while (n > 0)
67 {
68 n--;
69 if (p[n] == '\n')
70 {
71 base += n + 1;
72 goto done;
73 }
74 }
75
76 }
77 while (base != 0);
78
79 /* base is the new pointer. Seek to it exactly. */
80 done:
81 if (sseek (u->s, base, SEEK_SET) < 0)
82 goto io_error;
83 u->last_record--;
84 u->endfile = NO_ENDFILE;
85 u->last_char = EOF - 1;
86 return;
87
88 io_error:
89 generate_error (&fpp->common, LIBERROR_OS, NULL);
90 }
91
92
93 /* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
94 sequential file. We are guaranteed to be between records on entry and
95 we have to shift to the previous record. Loop over subrecords. */
96
97 static void
unformatted_backspace(st_parameter_filepos * fpp,gfc_unit * u)98 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
99 {
100 gfc_offset m, slen;
101 GFC_INTEGER_4 m4;
102 GFC_INTEGER_8 m8;
103 ssize_t length;
104 int continued;
105 char p[sizeof (GFC_INTEGER_8)];
106
107 if (compile_options.record_marker == 0)
108 length = sizeof (GFC_INTEGER_4);
109 else
110 length = compile_options.record_marker;
111
112 do
113 {
114 slen = - (gfc_offset) length;
115 if (sseek (u->s, slen, SEEK_CUR) < 0)
116 goto io_error;
117 if (sread (u->s, p, length) != length)
118 goto io_error;
119
120 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
121 if (likely (u->flags.convert == GFC_CONVERT_NATIVE))
122 {
123 switch (length)
124 {
125 case sizeof(GFC_INTEGER_4):
126 memcpy (&m4, p, sizeof (m4));
127 m = m4;
128 break;
129
130 case sizeof(GFC_INTEGER_8):
131 memcpy (&m8, p, sizeof (m8));
132 m = m8;
133 break;
134
135 default:
136 runtime_error ("Illegal value for record marker");
137 break;
138 }
139 }
140 else
141 {
142 uint32_t u32;
143 uint64_t u64;
144 switch (length)
145 {
146 case sizeof(GFC_INTEGER_4):
147 memcpy (&u32, p, sizeof (u32));
148 u32 = __builtin_bswap32 (u32);
149 memcpy (&m4, &u32, sizeof (m4));
150 m = m4;
151 break;
152
153 case sizeof(GFC_INTEGER_8):
154 memcpy (&u64, p, sizeof (u64));
155 u64 = __builtin_bswap64 (u64);
156 memcpy (&m8, &u64, sizeof (m8));
157 m = m8;
158 break;
159
160 default:
161 runtime_error ("Illegal value for record marker");
162 break;
163 }
164
165 }
166
167 continued = m < 0;
168 if (continued)
169 m = -m;
170
171 if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
172 goto io_error;
173 } while (continued);
174
175 u->last_record--;
176 return;
177
178 io_error:
179 generate_error (&fpp->common, LIBERROR_OS, NULL);
180 }
181
182
183 extern void st_backspace (st_parameter_filepos *);
184 export_proto(st_backspace);
185
186 void
st_backspace(st_parameter_filepos * fpp)187 st_backspace (st_parameter_filepos *fpp)
188 {
189 gfc_unit *u;
190
191 library_start (&fpp->common);
192
193 u = find_unit (fpp->common.unit);
194 if (u == NULL)
195 {
196 generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
197 goto done;
198 }
199
200 /* Direct access is prohibited, and so is unformatted stream access. */
201
202
203 if (u->flags.access == ACCESS_DIRECT)
204 {
205 generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
206 "Cannot BACKSPACE a file opened for DIRECT access");
207 goto done;
208 }
209
210 if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
211 {
212 generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
213 "Cannot BACKSPACE an unformatted stream file");
214 goto done;
215 }
216
217 /* Make sure format buffer is flushed and reset. */
218 if (u->flags.form == FORM_FORMATTED)
219 {
220 int pos = fbuf_reset (u);
221 if (pos != 0)
222 sseek (u->s, pos, SEEK_CUR);
223 }
224
225
226 /* Check for special cases involving the ENDFILE record first. */
227
228 if (u->endfile == AFTER_ENDFILE)
229 {
230 u->endfile = AT_ENDFILE;
231 u->flags.position = POSITION_APPEND;
232 sflush (u->s);
233 }
234 else
235 {
236 if (stell (u->s) == 0)
237 {
238 u->flags.position = POSITION_REWIND;
239 goto done; /* Common special case */
240 }
241
242 if (u->mode == WRITING)
243 {
244 /* If there are previously written bytes from a write with
245 ADVANCE="no", add a record marker before performing the
246 BACKSPACE. */
247
248 if (u->previous_nonadvancing_write)
249 finish_last_advance_record (u);
250
251 u->previous_nonadvancing_write = 0;
252
253 unit_truncate (u, stell (u->s), &fpp->common);
254 u->mode = READING;
255 }
256
257 if (u->flags.form == FORM_FORMATTED)
258 formatted_backspace (fpp, u);
259 else
260 unformatted_backspace (fpp, u);
261
262 u->flags.position = POSITION_UNSPECIFIED;
263 u->endfile = NO_ENDFILE;
264 u->current_record = 0;
265 u->bytes_left = 0;
266 }
267
268 done:
269 if (u != NULL)
270 unlock_unit (u);
271
272 library_end ();
273 }
274
275
276 extern void st_endfile (st_parameter_filepos *);
277 export_proto(st_endfile);
278
279 void
st_endfile(st_parameter_filepos * fpp)280 st_endfile (st_parameter_filepos *fpp)
281 {
282 gfc_unit *u;
283
284 library_start (&fpp->common);
285
286 u = find_unit (fpp->common.unit);
287 if (u != NULL)
288 {
289 if (u->flags.access == ACCESS_DIRECT)
290 {
291 generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
292 "Cannot perform ENDFILE on a file opened "
293 "for DIRECT access");
294 goto done;
295 }
296
297 if (u->flags.access == ACCESS_SEQUENTIAL
298 && u->endfile == AFTER_ENDFILE)
299 {
300 generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
301 "Cannot perform ENDFILE on a file already "
302 "positioned after the EOF marker");
303 goto done;
304 }
305
306 /* If there are previously written bytes from a write with ADVANCE="no",
307 add a record marker before performing the ENDFILE. */
308
309 if (u->previous_nonadvancing_write)
310 finish_last_advance_record (u);
311
312 u->previous_nonadvancing_write = 0;
313
314 if (u->current_record)
315 {
316 st_parameter_dt dtp;
317 dtp.common = fpp->common;
318 memset (&dtp.u.p, 0, sizeof (dtp.u.p));
319 dtp.u.p.current_unit = u;
320 next_record (&dtp, 1);
321 }
322
323 unit_truncate (u, stell (u->s), &fpp->common);
324 u->endfile = AFTER_ENDFILE;
325 u->last_char = EOF - 1;
326 if (0 == stell (u->s))
327 u->flags.position = POSITION_REWIND;
328 }
329 else
330 {
331 if (fpp->common.unit < 0)
332 {
333 generate_error (&fpp->common, LIBERROR_BAD_OPTION,
334 "Bad unit number in statement");
335 return;
336 }
337
338 u = find_or_create_unit (fpp->common.unit);
339 if (u->s == NULL)
340 {
341 /* Open the unit with some default flags. */
342 st_parameter_open opp;
343 unit_flags u_flags;
344
345 memset (&u_flags, '\0', sizeof (u_flags));
346 u_flags.access = ACCESS_SEQUENTIAL;
347 u_flags.action = ACTION_READWRITE;
348
349 /* Is it unformatted? */
350 if (!(fpp->common.flags & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
351 | IOPARM_DT_IONML_SET)))
352 u_flags.form = FORM_UNFORMATTED;
353 else
354 u_flags.form = FORM_UNSPECIFIED;
355
356 u_flags.delim = DELIM_UNSPECIFIED;
357 u_flags.blank = BLANK_UNSPECIFIED;
358 u_flags.pad = PAD_UNSPECIFIED;
359 u_flags.decimal = DECIMAL_UNSPECIFIED;
360 u_flags.encoding = ENCODING_UNSPECIFIED;
361 u_flags.async = ASYNC_UNSPECIFIED;
362 u_flags.round = ROUND_UNSPECIFIED;
363 u_flags.sign = SIGN_UNSPECIFIED;
364 u_flags.status = STATUS_UNKNOWN;
365 u_flags.convert = GFC_CONVERT_NATIVE;
366 u_flags.share = SHARE_UNSPECIFIED;
367 u_flags.cc = CC_UNSPECIFIED;
368
369 opp.common = fpp->common;
370 opp.common.flags &= IOPARM_COMMON_MASK;
371 u = new_unit (&opp, u, &u_flags);
372 if (u == NULL)
373 return;
374 u->endfile = AFTER_ENDFILE;
375 u->last_char = EOF - 1;
376 }
377 }
378
379 done:
380 unlock_unit (u);
381
382 library_end ();
383 }
384
385
386 extern void st_rewind (st_parameter_filepos *);
387 export_proto(st_rewind);
388
389 void
st_rewind(st_parameter_filepos * fpp)390 st_rewind (st_parameter_filepos *fpp)
391 {
392 gfc_unit *u;
393
394 library_start (&fpp->common);
395
396 u = find_unit (fpp->common.unit);
397 if (u != NULL)
398 {
399 if (u->flags.access == ACCESS_DIRECT)
400 generate_error (&fpp->common, LIBERROR_BAD_OPTION,
401 "Cannot REWIND a file opened for DIRECT access");
402 else
403 {
404 /* If there are previously written bytes from a write with ADVANCE="no",
405 add a record marker before performing the ENDFILE. */
406
407 if (u->previous_nonadvancing_write)
408 finish_last_advance_record (u);
409
410 u->previous_nonadvancing_write = 0;
411
412 fbuf_reset (u);
413
414 u->last_record = 0;
415
416 if (sseek (u->s, 0, SEEK_SET) < 0)
417 {
418 generate_error (&fpp->common, LIBERROR_OS, NULL);
419 library_end ();
420 return;
421 }
422
423 /* Set this for compatibilty with g77 for /dev/null. */
424 if (ssize (u->s) == 0)
425 u->endfile = AT_ENDFILE;
426 else
427 {
428 /* We are rewinding so we are not at the end. */
429 u->endfile = NO_ENDFILE;
430 }
431
432 u->current_record = 0;
433 u->strm_pos = 1;
434 u->read_bad = 0;
435 u->last_char = EOF - 1;
436 }
437 /* Update position for INQUIRE. */
438 u->flags.position = POSITION_REWIND;
439 unlock_unit (u);
440 }
441
442 library_end ();
443 }
444
445
446 extern void st_flush (st_parameter_filepos *);
447 export_proto(st_flush);
448
449 void
st_flush(st_parameter_filepos * fpp)450 st_flush (st_parameter_filepos *fpp)
451 {
452 gfc_unit *u;
453
454 library_start (&fpp->common);
455
456 u = find_unit (fpp->common.unit);
457 if (u != NULL)
458 {
459 /* Make sure format buffer is flushed. */
460 if (u->flags.form == FORM_FORMATTED)
461 fbuf_flush (u, u->mode);
462
463 sflush (u->s);
464 u->last_char = EOF - 1;
465 unlock_unit (u);
466 }
467 else
468 /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
469 generate_error (&fpp->common, LIBERROR_BAD_OPTION,
470 "Specified UNIT in FLUSH is not connected");
471
472 library_end ();
473 }
474