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