1 /* Copyright (C) 2002-2003, 2005, 2006, 2007, 2009 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)
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/>. */
30 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
31 ENDFILE, and REWIND as well as the FLUSH statement. */
34 /* formatted_backspace(fpp, u)-- Move the file back one line. The
35 current position is after the newline that terminates the previous
36 record, and we have to sift backwards to find the newline before
37 that or the start of the file, whichever comes first. */
39 static const int READ_CHUNK
= 4096;
42 formatted_backspace (st_parameter_filepos
*fpp
, gfc_unit
*u
)
48 base
= stell (u
->s
) - 1;
52 n
= (base
< READ_CHUNK
) ? base
: READ_CHUNK
;
54 if (sseek (u
->s
, base
, SEEK_SET
) < 0)
56 if (sread (u
->s
, p
, n
) != n
)
59 /* We have moved backwards from the current position, it should
60 not be possible to get a short read. Because it is not
61 clear what to do about such thing, we ignore the possibility. */
63 /* There is no memrchr() in the C library, so we have to do it
79 /* base is the new pointer. Seek to it exactly. */
81 if (sseek (u
->s
, base
, SEEK_SET
) < 0)
84 u
->endfile
= NO_ENDFILE
;
89 generate_error (&fpp
->common
, LIBERROR_OS
, NULL
);
93 /* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
94 sequential file. We are guaranteed to be between records on entry and
95 we have to shift to the previous record. Loop over subrecords. */
98 unformatted_backspace (st_parameter_filepos
*fpp
, gfc_unit
*u
)
105 char p
[sizeof (GFC_INTEGER_8
)];
107 if (compile_options
.record_marker
== 0)
108 length
= sizeof (GFC_INTEGER_4
);
110 length
= compile_options
.record_marker
;
114 slen
= - (gfc_offset
) length
;
115 if (sseek (u
->s
, slen
, SEEK_CUR
) < 0)
117 if (sread (u
->s
, p
, length
) != length
)
120 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
121 if (likely (u
->flags
.convert
== GFC_CONVERT_NATIVE
))
125 case sizeof(GFC_INTEGER_4
):
126 memcpy (&m4
, p
, sizeof (m4
));
130 case sizeof(GFC_INTEGER_8
):
131 memcpy (&m8
, p
, sizeof (m8
));
136 runtime_error ("Illegal value for record marker");
144 case sizeof(GFC_INTEGER_4
):
145 reverse_memcpy (&m4
, p
, sizeof (m4
));
149 case sizeof(GFC_INTEGER_8
):
150 reverse_memcpy (&m8
, p
, sizeof (m8
));
155 runtime_error ("Illegal value for record marker");
165 if (sseek (u
->s
, -m
-2 * length
, SEEK_CUR
) < 0)
173 generate_error (&fpp
->common
, LIBERROR_OS
, NULL
);
177 extern void st_backspace (st_parameter_filepos
*);
178 export_proto(st_backspace
);
181 st_backspace (st_parameter_filepos
*fpp
)
185 library_start (&fpp
->common
);
187 u
= find_unit (fpp
->common
.unit
);
190 generate_error (&fpp
->common
, LIBERROR_BAD_UNIT
, NULL
);
194 /* Direct access is prohibited, and so is unformatted stream access. */
197 if (u
->flags
.access
== ACCESS_DIRECT
)
199 generate_error (&fpp
->common
, LIBERROR_OPTION_CONFLICT
,
200 "Cannot BACKSPACE a file opened for DIRECT access");
204 if (u
->flags
.access
== ACCESS_STREAM
&& u
->flags
.form
== FORM_UNFORMATTED
)
206 generate_error (&fpp
->common
, LIBERROR_OPTION_CONFLICT
,
207 "Cannot BACKSPACE an unformatted stream file");
211 /* Make sure format buffer is flushed and reset. */
212 if (u
->flags
.form
== FORM_FORMATTED
)
214 int pos
= fbuf_reset (u
);
216 sseek (u
->s
, pos
, SEEK_CUR
);
220 /* Check for special cases involving the ENDFILE record first. */
222 if (u
->endfile
== AFTER_ENDFILE
)
224 u
->endfile
= AT_ENDFILE
;
225 u
->flags
.position
= POSITION_APPEND
;
230 if (stell (u
->s
) == 0)
232 u
->flags
.position
= POSITION_REWIND
;
233 goto done
; /* Common special case */
236 if (u
->mode
== WRITING
)
238 /* If there are previously written bytes from a write with
239 ADVANCE="no", add a record marker before performing the
242 if (u
->previous_nonadvancing_write
)
243 finish_last_advance_record (u
);
245 u
->previous_nonadvancing_write
= 0;
247 unit_truncate (u
, stell (u
->s
), &fpp
->common
);
251 if (u
->flags
.form
== FORM_FORMATTED
)
252 formatted_backspace (fpp
, u
);
254 unformatted_backspace (fpp
, u
);
256 u
->flags
.position
= POSITION_UNSPECIFIED
;
257 u
->endfile
= NO_ENDFILE
;
258 u
->current_record
= 0;
270 extern void st_endfile (st_parameter_filepos
*);
271 export_proto(st_endfile
);
274 st_endfile (st_parameter_filepos
*fpp
)
278 library_start (&fpp
->common
);
280 u
= find_unit (fpp
->common
.unit
);
283 if (u
->flags
.access
== ACCESS_DIRECT
)
285 generate_error (&fpp
->common
, LIBERROR_OPTION_CONFLICT
,
286 "Cannot perform ENDFILE on a file opened"
287 " for DIRECT access");
291 /* If there are previously written bytes from a write with ADVANCE="no",
292 add a record marker before performing the ENDFILE. */
294 if (u
->previous_nonadvancing_write
)
295 finish_last_advance_record (u
);
297 u
->previous_nonadvancing_write
= 0;
299 if (u
->current_record
)
302 dtp
.common
= fpp
->common
;
303 memset (&dtp
.u
.p
, 0, sizeof (dtp
.u
.p
));
304 dtp
.u
.p
.current_unit
= u
;
305 next_record (&dtp
, 1);
308 unit_truncate (u
, stell (u
->s
), &fpp
->common
);
309 u
->endfile
= AFTER_ENDFILE
;
310 if (0 == stell (u
->s
))
311 u
->flags
.position
= POSITION_REWIND
;
320 extern void st_rewind (st_parameter_filepos
*);
321 export_proto(st_rewind
);
324 st_rewind (st_parameter_filepos
*fpp
)
328 library_start (&fpp
->common
);
330 u
= find_unit (fpp
->common
.unit
);
333 if (u
->flags
.access
== ACCESS_DIRECT
)
334 generate_error (&fpp
->common
, LIBERROR_BAD_OPTION
,
335 "Cannot REWIND a file opened for DIRECT access");
338 /* If there are previously written bytes from a write with ADVANCE="no",
339 add a record marker before performing the ENDFILE. */
341 if (u
->previous_nonadvancing_write
)
342 finish_last_advance_record (u
);
344 u
->previous_nonadvancing_write
= 0;
350 if (sseek (u
->s
, 0, SEEK_SET
) < 0)
351 generate_error (&fpp
->common
, LIBERROR_OS
, NULL
);
353 /* Handle special files like /dev/null differently. */
354 if (!is_special (u
->s
))
356 /* We are rewinding so we are not at the end. */
357 u
->endfile
= NO_ENDFILE
;
361 /* Set this for compatibilty with g77 for /dev/null. */
362 if (file_length (u
->s
) == 0 && stell (u
->s
) == 0)
363 u
->endfile
= AT_ENDFILE
;
364 /* Future refinements on special files can go here. */
367 u
->current_record
= 0;
371 /* Update position for INQUIRE. */
372 u
->flags
.position
= POSITION_REWIND
;
380 extern void st_flush (st_parameter_filepos
*);
381 export_proto(st_flush
);
384 st_flush (st_parameter_filepos
*fpp
)
388 library_start (&fpp
->common
);
390 u
= find_unit (fpp
->common
.unit
);
393 /* Make sure format buffer is flushed. */
394 if (u
->flags
.form
== FORM_FORMATTED
)
395 fbuf_flush (u
, u
->mode
);
401 /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
402 generate_error (&fpp
->common
, LIBERROR_BAD_OPTION
,
403 "Specified UNIT in FLUSH is not connected");