Fix SIMD clone SLP a bit more
[official-gcc.git] / libgfortran / io / file_pos.c
blob80560ab61d10ca2078d4b26b1500b86afb56e075
1 /* Copyright (C) 2002-2023 Free Software Foundation, Inc.
2 Contributed by Andy Vaught and Janne Blomqvist
4 This file is part of the GNU Fortran runtime library (libgfortran).
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.
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.
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.
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/>. */
25 #include "io.h"
26 #include "fbuf.h"
27 #include "unix.h"
28 #include "async.h"
29 #include <string.h>
31 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
32 ENDFILE, and REWIND as well as the FLUSH statement. */
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. */
40 #define READ_CHUNK 4096
42 static void
43 formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
45 gfc_offset base;
46 char p[READ_CHUNK];
47 ssize_t n;
49 base = stell (u->s) - 1;
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;
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. */
64 /* There is no memrchr() in the C library, so we have to do it
65 ourselves. */
67 while (n > 0)
69 n--;
70 if (p[n] == '\n')
72 base += n + 1;
73 goto done;
78 while (base != 0);
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;
89 io_error:
90 generate_error (&fpp->common, LIBERROR_OS, NULL);
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. */
98 static void
99 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
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;
109 #ifdef HAVE_GFC_REAL_17
110 convert &= ~(GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM);
111 #endif
113 if (compile_options.record_marker == 0)
114 length = sizeof (GFC_INTEGER_4);
115 else
116 length = compile_options.record_marker;
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;
126 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
127 if (likely (convert == GFC_CONVERT_NATIVE))
129 switch (length)
131 case sizeof(GFC_INTEGER_4):
132 memcpy (&m4, p, sizeof (m4));
133 m = m4;
134 break;
136 case sizeof(GFC_INTEGER_8):
137 memcpy (&m8, p, sizeof (m8));
138 m = m8;
139 break;
141 default:
142 runtime_error ("Illegal value for record marker");
143 break;
146 else
148 uint32_t u32;
149 uint64_t u64;
150 switch (length)
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;
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;
166 default:
167 runtime_error ("Illegal value for record marker");
168 break;
173 continued = m < 0;
174 if (continued)
175 m = -m;
177 if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
178 goto io_error;
179 } while (continued);
181 u->last_record--;
182 return;
184 io_error:
185 generate_error (&fpp->common, LIBERROR_OS, NULL);
189 extern void st_backspace (st_parameter_filepos *);
190 export_proto(st_backspace);
192 void
193 st_backspace (st_parameter_filepos *fpp)
195 gfc_unit *u;
196 bool needs_unlock = false;
198 library_start (&fpp->common);
200 u = find_unit (fpp->common.unit);
201 if (u == NULL)
203 generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
204 goto done;
207 /* Direct access is prohibited, and so is unformatted stream access. */
210 if (u->flags.access == ACCESS_DIRECT)
212 generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
213 "Cannot BACKSPACE a file opened for DIRECT access");
214 goto done;
217 if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
219 generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
220 "Cannot BACKSPACE an unformatted stream file");
221 goto done;
224 if (ASYNC_IO && u->au)
226 if (async_wait (&(fpp->common), u->au))
227 return;
228 else
230 needs_unlock = true;
231 LOCK (&u->au->io_lock);
235 /* Make sure format buffer is flushed and reset. */
236 if (u->flags.form == FORM_FORMATTED)
238 int pos = fbuf_reset (u);
239 if (pos != 0)
240 sseek (u->s, pos, SEEK_CUR);
244 /* Check for special cases involving the ENDFILE record first. */
246 if (u->endfile == AFTER_ENDFILE)
248 u->endfile = AT_ENDFILE;
249 u->flags.position = POSITION_APPEND;
250 sflush (u->s);
252 else
254 if (stell (u->s) == 0)
256 u->flags.position = POSITION_REWIND;
257 goto done; /* Common special case */
260 if (u->mode == WRITING)
262 /* If there are previously written bytes from a write with
263 ADVANCE="no", add a record marker before performing the
264 BACKSPACE. */
266 if (u->previous_nonadvancing_write)
267 finish_last_advance_record (u);
269 u->previous_nonadvancing_write = 0;
271 unit_truncate (u, stell (u->s), &fpp->common);
272 u->mode = READING;
275 if (u->flags.form == FORM_FORMATTED)
276 formatted_backspace (fpp, u);
277 else
278 unformatted_backspace (fpp, u);
280 u->flags.position = POSITION_UNSPECIFIED;
281 u->endfile = NO_ENDFILE;
282 u->current_record = 0;
283 u->bytes_left = 0;
286 done:
287 if (u != NULL)
289 unlock_unit (u);
291 if (ASYNC_IO && u->au && needs_unlock)
292 UNLOCK (&u->au->io_lock);
295 library_end ();
299 extern void st_endfile (st_parameter_filepos *);
300 export_proto(st_endfile);
302 void
303 st_endfile (st_parameter_filepos *fpp)
305 gfc_unit *u;
306 bool needs_unlock = false;
308 library_start (&fpp->common);
310 u = find_unit (fpp->common.unit);
311 if (u != NULL)
313 if (u->flags.access == ACCESS_DIRECT)
315 generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
316 "Cannot perform ENDFILE on a file opened "
317 "for DIRECT access");
318 goto done;
321 if (ASYNC_IO && u->au)
323 if (async_wait (&(fpp->common), u->au))
324 return;
325 else
327 needs_unlock = true;
328 LOCK (&u->au->io_lock);
332 if (u->flags.access == ACCESS_SEQUENTIAL
333 && u->endfile == AFTER_ENDFILE)
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;
341 /* If there are previously written bytes from a write with ADVANCE="no",
342 add a record marker before performing the ENDFILE. */
344 if (u->previous_nonadvancing_write)
345 finish_last_advance_record (u);
347 u->previous_nonadvancing_write = 0;
349 if (u->current_record)
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);
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;
364 else
366 if (fpp->common.unit < 0)
368 generate_error (&fpp->common, LIBERROR_BAD_OPTION,
369 "Bad unit number in statement");
370 return;
373 u = find_or_create_unit (fpp->common.unit);
374 if (u->s == NULL)
376 /* Open the unit with some default flags. */
377 st_parameter_open opp;
378 unit_flags u_flags;
380 memset (&u_flags, '\0', sizeof (u_flags));
381 u_flags.access = ACCESS_SEQUENTIAL;
382 u_flags.action = ACTION_READWRITE;
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;
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;
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;
414 done:
415 if (ASYNC_IO && u->au && needs_unlock)
416 UNLOCK (&u->au->io_lock);
418 unlock_unit (u);
420 library_end ();
424 extern void st_rewind (st_parameter_filepos *);
425 export_proto(st_rewind);
427 void
428 st_rewind (st_parameter_filepos *fpp)
430 gfc_unit *u;
431 bool needs_unlock = true;
433 library_start (&fpp->common);
435 u = find_unit (fpp->common.unit);
436 if (u != NULL)
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
443 if (ASYNC_IO && u->au)
445 if (async_wait (&(fpp->common), u->au))
446 return;
447 else
449 needs_unlock = true;
450 LOCK (&u->au->io_lock);
454 /* If there are previously written bytes from a write with ADVANCE="no",
455 add a record marker before performing the ENDFILE. */
457 if (u->previous_nonadvancing_write)
458 finish_last_advance_record (u);
460 u->previous_nonadvancing_write = 0;
462 fbuf_reset (u);
464 u->last_record = 0;
466 if (sseek (u->s, 0, SEEK_SET) < 0)
468 generate_error (&fpp->common, LIBERROR_OS, NULL);
469 library_end ();
470 return;
473 /* Set this for compatibilty with g77 for /dev/null. */
474 if (ssize (u->s) == 0)
475 u->endfile = AT_ENDFILE;
476 else
478 /* We are rewinding so we are not at the end. */
479 u->endfile = NO_ENDFILE;
482 u->current_record = 0;
483 u->strm_pos = 1;
484 u->read_bad = 0;
485 u->last_char = EOF - 1;
487 /* Update position for INQUIRE. */
488 u->flags.position = POSITION_REWIND;
490 if (ASYNC_IO && u->au && needs_unlock)
491 UNLOCK (&u->au->io_lock);
493 unlock_unit (u);
496 library_end ();
500 extern void st_flush (st_parameter_filepos *);
501 export_proto(st_flush);
503 void
504 st_flush (st_parameter_filepos *fpp)
506 gfc_unit *u;
507 bool needs_unlock = false;
509 library_start (&fpp->common);
511 u = find_unit (fpp->common.unit);
512 if (u != NULL)
514 if (ASYNC_IO && u->au)
516 if (async_wait (&(fpp->common), u->au))
517 return;
518 else
520 needs_unlock = true;
521 LOCK (&u->au->io_lock);
525 /* Make sure format buffer is flushed. */
526 if (u->flags.form == FORM_FORMATTED)
527 fbuf_flush (u, u->mode);
529 sflush (u->s);
530 u->last_char = EOF - 1;
531 unlock_unit (u);
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");
538 if (needs_unlock)
539 UNLOCK (&u->au->io_lock);
541 library_end ();