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