1 /* Copyright (C) 2002-2003, 2005, 2006, 2007, 2009, 2010
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught and Janne Blomqvist
5 This file is part of the GNU Fortran runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
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 static const int READ_CHUNK = 4096;
43 formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
49 base = stell (u->s) - 1;
53 n = (base < READ_CHUNK) ? base : READ_CHUNK;
55 if (sseek (u->s, base, SEEK_SET) < 0)
57 if (sread (u->s, p, n) != n)
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
80 /* base is the new pointer. Seek to it exactly. */
82 if (sseek (u->s, base, SEEK_SET) < 0)
85 u->endfile = NO_ENDFILE;
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. */
99 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
106 char p[sizeof (GFC_INTEGER_8)];
108 if (compile_options.record_marker == 0)
109 length = sizeof (GFC_INTEGER_4);
111 length = compile_options.record_marker;
115 slen = - (gfc_offset) length;
116 if (sseek (u->s, slen, SEEK_CUR) < 0)
118 if (sread (u->s, p, length) != length)
121 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
122 if (likely (u->flags.convert == GFC_CONVERT_NATIVE))
126 case sizeof(GFC_INTEGER_4):
127 memcpy (&m4, p, sizeof (m4));
131 case sizeof(GFC_INTEGER_8):
132 memcpy (&m8, p, sizeof (m8));
137 runtime_error ("Illegal value for record marker");
145 case sizeof(GFC_INTEGER_4):
146 reverse_memcpy (&m4, p, sizeof (m4));
150 case sizeof(GFC_INTEGER_8):
151 reverse_memcpy (&m8, p, sizeof (m8));
156 runtime_error ("Illegal value for record marker");
166 if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
174 generate_error (&fpp->common, LIBERROR_OS, NULL);
178 extern void st_backspace (st_parameter_filepos *);
179 export_proto(st_backspace);
182 st_backspace (st_parameter_filepos *fpp)
186 library_start (&fpp->common);
188 u = find_unit (fpp->common.unit);
191 generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
195 /* Direct access is prohibited, and so is unformatted stream access. */
198 if (u->flags.access == ACCESS_DIRECT)
200 generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
201 "Cannot BACKSPACE a file opened for DIRECT access");
205 if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
207 generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
208 "Cannot BACKSPACE an unformatted stream file");
212 /* Make sure format buffer is flushed and reset. */
213 if (u->flags.form == FORM_FORMATTED)
215 int pos = fbuf_reset (u);
217 sseek (u->s, pos, SEEK_CUR);
221 /* Check for special cases involving the ENDFILE record first. */
223 if (u->endfile == AFTER_ENDFILE)
225 u->endfile = AT_ENDFILE;
226 u->flags.position = POSITION_APPEND;
231 if (stell (u->s) == 0)
233 u->flags.position = POSITION_REWIND;
234 goto done; /* Common special case */
237 if (u->mode == WRITING)
239 /* If there are previously written bytes from a write with
240 ADVANCE="no", add a record marker before performing the
243 if (u->previous_nonadvancing_write)
244 finish_last_advance_record (u);
246 u->previous_nonadvancing_write = 0;
248 unit_truncate (u, stell (u->s), &fpp->common);
252 if (u->flags.form == FORM_FORMATTED)
253 formatted_backspace (fpp, u);
255 unformatted_backspace (fpp, u);
257 u->flags.position = POSITION_UNSPECIFIED;
258 u->endfile = NO_ENDFILE;
259 u->current_record = 0;
271 extern void st_endfile (st_parameter_filepos *);
272 export_proto(st_endfile);
275 st_endfile (st_parameter_filepos *fpp)
279 library_start (&fpp->common);
281 u = find_unit (fpp->common.unit);
284 if (u->flags.access == ACCESS_DIRECT)
286 generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
287 "Cannot perform ENDFILE on a file opened "
288 "for DIRECT access");
292 if (u->flags.access == ACCESS_SEQUENTIAL
293 && u->endfile == AFTER_ENDFILE)
295 generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
296 "Cannot perform ENDFILE on a file already "
297 "positioned after the EOF marker");
301 /* If there are previously written bytes from a write with ADVANCE="no",
302 add a record marker before performing the ENDFILE. */
304 if (u->previous_nonadvancing_write)
305 finish_last_advance_record (u);
307 u->previous_nonadvancing_write = 0;
309 if (u->current_record)
312 dtp.common = fpp->common;
313 memset (&dtp.u.p, 0, sizeof (dtp.u.p));
314 dtp.u.p.current_unit = u;
315 next_record (&dtp, 1);
318 unit_truncate (u, stell (u->s), &fpp->common);
319 u->endfile = AFTER_ENDFILE;
320 if (0 == stell (u->s))
321 u->flags.position = POSITION_REWIND;
325 if (fpp->common.unit < 0)
327 generate_error (&fpp->common, LIBERROR_BAD_OPTION,
328 "Bad unit number in statement");
332 u = find_or_create_unit (fpp->common.unit);
335 /* Open the unit with some default flags. */
336 st_parameter_open opp;
339 memset (&u_flags, '\0', sizeof (u_flags));
340 u_flags.access = ACCESS_SEQUENTIAL;
341 u_flags.action = ACTION_READWRITE;
343 /* Is it unformatted? */
344 if (!(fpp->common.flags & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
345 | IOPARM_DT_IONML_SET)))
346 u_flags.form = FORM_UNFORMATTED;
348 u_flags.form = FORM_UNSPECIFIED;
350 u_flags.delim = DELIM_UNSPECIFIED;
351 u_flags.blank = BLANK_UNSPECIFIED;
352 u_flags.pad = PAD_UNSPECIFIED;
353 u_flags.decimal = DECIMAL_UNSPECIFIED;
354 u_flags.encoding = ENCODING_UNSPECIFIED;
355 u_flags.async = ASYNC_UNSPECIFIED;
356 u_flags.round = ROUND_UNSPECIFIED;
357 u_flags.sign = SIGN_UNSPECIFIED;
358 u_flags.status = STATUS_UNKNOWN;
359 u_flags.convert = GFC_CONVERT_NATIVE;
361 opp.common = fpp->common;
362 opp.common.flags &= IOPARM_COMMON_MASK;
363 u = new_unit (&opp, u, &u_flags);
366 u->endfile = AFTER_ENDFILE;
377 extern void st_rewind (st_parameter_filepos *);
378 export_proto(st_rewind);
381 st_rewind (st_parameter_filepos *fpp)
385 library_start (&fpp->common);
387 u = find_unit (fpp->common.unit);
390 if (u->flags.access == ACCESS_DIRECT)
391 generate_error (&fpp->common, LIBERROR_BAD_OPTION,
392 "Cannot REWIND a file opened for DIRECT access");
395 /* If there are previously written bytes from a write with ADVANCE="no",
396 add a record marker before performing the ENDFILE. */
398 if (u->previous_nonadvancing_write)
399 finish_last_advance_record (u);
401 u->previous_nonadvancing_write = 0;
407 if (sseek (u->s, 0, SEEK_SET) < 0)
408 generate_error (&fpp->common, LIBERROR_OS, NULL);
410 /* Set this for compatibilty with g77 for /dev/null. */
411 if (ssize (u->s) == 0)
412 u->endfile = AT_ENDFILE;
415 /* We are rewinding so we are not at the end. */
416 u->endfile = NO_ENDFILE;
419 u->current_record = 0;
423 /* Update position for INQUIRE. */
424 u->flags.position = POSITION_REWIND;
432 extern void st_flush (st_parameter_filepos *);
433 export_proto(st_flush);
436 st_flush (st_parameter_filepos *fpp)
440 library_start (&fpp->common);
442 u = find_unit (fpp->common.unit);
445 /* Make sure format buffer is flushed. */
446 if (u->flags.form == FORM_FORMATTED)
447 fbuf_flush (u, u->mode);
453 /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
454 generate_error (&fpp->common, LIBERROR_BAD_OPTION,
455 "Specified UNIT in FLUSH is not connected");