1 /* Copyright (C) 2002-2003, 2005, 2006, 2007 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 2, or (at your option)
11 In addition to the permissions in the GNU General Public License, the
12 Free Software Foundation gives you unlimited permission to link the
13 compiled version of this file into combinations with other programs,
14 and to distribute those combinations without any restriction coming
15 from the use of this file. (The General Public License restrictions
16 do apply in other respects; for example, they cover modification of
17 the file, and distribution when not linked into a combine
20 Libgfortran is distributed in the hope that it will be useful,
21 but WITHOUT ANY WARRANTY; without even the implied warranty of
22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 GNU General Public License for more details.
25 You should have received a copy of the GNU General Public License
26 along with Libgfortran; see the file COPYING. If not, write to
27 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
28 Boston, MA 02110-1301, USA. */
33 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
34 ENDFILE, and REWIND as well as the FLUSH statement. */
37 /* formatted_backspace(fpp, u)-- Move the file back one line. The
38 current position is after the newline that terminates the previous
39 record, and we have to sift backwards to find the newline before
40 that or the start of the file, whichever comes first. */
42 static const int READ_CHUNK = 4096;
45 formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
51 base = stell (u->s) - 1;
55 n = (base < READ_CHUNK) ? base : READ_CHUNK;
57 if (sseek (u->s, base, SEEK_SET) < 0)
59 if (sread (u->s, p, n) != n)
62 /* We have moved backwards from the current position, it should
63 not be possible to get a short read. Because it is not
64 clear what to do about such thing, we ignore the possibility. */
66 /* There is no memrchr() in the C library, so we have to do it
82 /* base is the new pointer. Seek to it exactly. */
84 if (sseek (u->s, base, SEEK_SET) < 0)
87 u->endfile = NO_ENDFILE;
92 generate_error (&fpp->common, LIBERROR_OS, NULL);
96 /* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
97 sequential file. We are guaranteed to be between records on entry and
98 we have to shift to the previous record. Loop over subrecords. */
101 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
108 char p[sizeof (GFC_INTEGER_8)];
110 if (compile_options.record_marker == 0)
111 length = sizeof (GFC_INTEGER_4);
113 length = compile_options.record_marker;
117 slen = - (gfc_offset) length;
118 if (sseek (u->s, slen, SEEK_CUR) < 0)
120 if (sread (u->s, p, length) != length)
123 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
124 if (likely (u->flags.convert == GFC_CONVERT_NATIVE))
128 case sizeof(GFC_INTEGER_4):
129 memcpy (&m4, p, sizeof (m4));
133 case sizeof(GFC_INTEGER_8):
134 memcpy (&m8, p, sizeof (m8));
139 runtime_error ("Illegal value for record marker");
147 case sizeof(GFC_INTEGER_4):
148 reverse_memcpy (&m4, p, sizeof (m4));
152 case sizeof(GFC_INTEGER_8):
153 reverse_memcpy (&m8, p, sizeof (m8));
158 runtime_error ("Illegal value for record marker");
168 if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
176 generate_error (&fpp->common, LIBERROR_OS, NULL);
180 extern void st_backspace (st_parameter_filepos *);
181 export_proto(st_backspace);
184 st_backspace (st_parameter_filepos *fpp)
188 library_start (&fpp->common);
190 u = find_unit (fpp->common.unit);
193 generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
197 /* Direct access is prohibited, and so is unformatted stream access. */
200 if (u->flags.access == ACCESS_DIRECT)
202 generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
203 "Cannot BACKSPACE a file opened for DIRECT access");
207 if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
209 generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
210 "Cannot BACKSPACE an unformatted stream file");
214 /* Make sure format buffer is flushed and reset. */
215 if (u->flags.form == FORM_FORMATTED)
217 int pos = fbuf_reset (u);
219 sseek (u->s, pos, SEEK_CUR);
223 /* Check for special cases involving the ENDFILE record first. */
225 if (u->endfile == AFTER_ENDFILE)
227 u->endfile = AT_ENDFILE;
228 u->flags.position = POSITION_APPEND;
233 if (stell (u->s) == 0)
235 u->flags.position = POSITION_REWIND;
236 goto done; /* Common special case */
239 if (u->mode == WRITING)
241 /* If there are previously written bytes from a write with
242 ADVANCE="no", add a record marker before performing the
245 if (u->previous_nonadvancing_write)
246 finish_last_advance_record (u);
248 u->previous_nonadvancing_write = 0;
250 unit_truncate (u, stell (u->s), &fpp->common);
254 if (u->flags.form == FORM_FORMATTED)
255 formatted_backspace (fpp, u);
257 unformatted_backspace (fpp, u);
259 u->flags.position = POSITION_UNSPECIFIED;
260 u->endfile = NO_ENDFILE;
261 u->current_record = 0;
273 extern void st_endfile (st_parameter_filepos *);
274 export_proto(st_endfile);
277 st_endfile (st_parameter_filepos *fpp)
281 library_start (&fpp->common);
283 u = find_unit (fpp->common.unit);
286 if (u->flags.access == ACCESS_DIRECT)
288 generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
289 "Cannot perform ENDFILE on a file opened"
290 " for DIRECT access");
294 /* If there are previously written bytes from a write with ADVANCE="no",
295 add a record marker before performing the ENDFILE. */
297 if (u->previous_nonadvancing_write)
298 finish_last_advance_record (u);
300 u->previous_nonadvancing_write = 0;
302 if (u->current_record)
305 dtp.common = fpp->common;
306 memset (&dtp.u.p, 0, sizeof (dtp.u.p));
307 dtp.u.p.current_unit = u;
308 next_record (&dtp, 1);
311 unit_truncate (u, stell (u->s), &fpp->common);
312 u->endfile = AFTER_ENDFILE;
313 if (0 == stell (u->s))
314 u->flags.position = POSITION_REWIND;
323 extern void st_rewind (st_parameter_filepos *);
324 export_proto(st_rewind);
327 st_rewind (st_parameter_filepos *fpp)
331 library_start (&fpp->common);
333 u = find_unit (fpp->common.unit);
336 if (u->flags.access == ACCESS_DIRECT)
337 generate_error (&fpp->common, LIBERROR_BAD_OPTION,
338 "Cannot REWIND a file opened for DIRECT access");
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 /* Flush the buffers. If we have been writing to the file, the last
350 written record is the last record in the file, so truncate the
351 file now. Reset to read mode so two consecutive rewind
352 statements do not delete the file contents. */
353 if (u->mode == WRITING)
355 /* unit_truncate takes care of flushing. */
356 unit_truncate (u, stell (u->s), &fpp->common);
357 /* .. but we still need to reset since we're going to seek. */
362 /* Make sure buffers are reset. */
363 if (u->flags.form == FORM_FORMATTED)
371 if (sseek (u->s, 0, SEEK_SET) < 0)
372 generate_error (&fpp->common, LIBERROR_OS, NULL);
374 /* Handle special files like /dev/null differently. */
375 if (!is_special (u->s))
377 /* We are rewinding so we are not at the end. */
378 u->endfile = NO_ENDFILE;
382 /* Set this for compatibilty with g77 for /dev/null. */
383 if (file_length (u->s) == 0 && stell (u->s) == 0)
384 u->endfile = AT_ENDFILE;
385 /* Future refinements on special files can go here. */
388 u->current_record = 0;
392 /* Update position for INQUIRE. */
393 u->flags.position = POSITION_REWIND;
401 extern void st_flush (st_parameter_filepos *);
402 export_proto(st_flush);
405 st_flush (st_parameter_filepos *fpp)
409 library_start (&fpp->common);
411 u = find_unit (fpp->common.unit);
414 /* Make sure format buffer is flushed. */
415 if (u->flags.form == FORM_FORMATTED)
416 fbuf_flush (u, u->mode);
422 /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
423 generate_error (&fpp->common, LIBERROR_BAD_OPTION,
424 "Specified UNIT in FLUSH is not connected");