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 #define READ_CHUNK 4096
45 formatted_backspace (st_parameter_filepos
*fpp
, gfc_unit
*u
)
51 base
= file_position (u
->s
) - 1;
55 n
= (base
< READ_CHUNK
) ? base
: READ_CHUNK
;
58 p
= salloc_r_at (u
->s
, &n
, base
);
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
83 /* base is the new pointer. Seek to it exactly. */
85 if (sseek (u
->s
, base
) == FAILURE
)
88 u
->endfile
= NO_ENDFILE
;
93 generate_error (&fpp
->common
, LIBERROR_OS
, NULL
);
97 /* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
98 sequential file. We are guaranteed to be between records on entry and
99 we have to shift to the previous record. Loop over subrecords. */
102 unformatted_backspace (st_parameter_filepos
*fpp
, gfc_unit
*u
)
107 int length
, length_read
;
111 if (compile_options
.record_marker
== 0)
112 length
= sizeof (GFC_INTEGER_4
);
114 length
= compile_options
.record_marker
;
118 length_read
= length
;
120 p
= salloc_r_at (u
->s
, &length_read
,
121 file_position (u
->s
) - length
);
122 if (p
== NULL
|| length_read
!= length
)
125 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
126 if (u
->flags
.convert
== GFC_CONVERT_NATIVE
)
130 case sizeof(GFC_INTEGER_4
):
131 memcpy (&m4
, p
, sizeof (m4
));
135 case sizeof(GFC_INTEGER_8
):
136 memcpy (&m8
, p
, sizeof (m8
));
141 runtime_error ("Illegal value for record marker");
149 case sizeof(GFC_INTEGER_4
):
150 reverse_memcpy (&m4
, p
, sizeof (m4
));
154 case sizeof(GFC_INTEGER_8
):
155 reverse_memcpy (&m8
, p
, sizeof (m8
));
160 runtime_error ("Illegal value for record marker");
170 if ((new = file_position (u
->s
) - m
- 2*length
) < 0)
173 if (sseek (u
->s
, new) == FAILURE
)
181 generate_error (&fpp
->common
, LIBERROR_OS
, NULL
);
185 extern void st_backspace (st_parameter_filepos
*);
186 export_proto(st_backspace
);
189 st_backspace (st_parameter_filepos
*fpp
)
193 library_start (&fpp
->common
);
195 u
= find_unit (fpp
->common
.unit
);
198 generate_error (&fpp
->common
, LIBERROR_BAD_UNIT
, NULL
);
202 /* Direct access is prohibited, and so is unformatted stream access. */
205 if (u
->flags
.access
== ACCESS_DIRECT
)
207 generate_error (&fpp
->common
, LIBERROR_OPTION_CONFLICT
,
208 "Cannot BACKSPACE a file opened for DIRECT access");
212 if (u
->flags
.access
== ACCESS_STREAM
&& u
->flags
.form
== FORM_UNFORMATTED
)
214 generate_error (&fpp
->common
, LIBERROR_OPTION_CONFLICT
,
215 "Cannot BACKSPACE an unformatted stream file");
219 /* Check for special cases involving the ENDFILE record first. */
221 if (u
->endfile
== AFTER_ENDFILE
)
223 u
->endfile
= AT_ENDFILE
;
224 u
->flags
.position
= POSITION_APPEND
;
229 if (file_position (u
->s
) == 0)
231 u
->flags
.position
= POSITION_REWIND
;
232 goto done
; /* Common special case */
235 if (u
->mode
== WRITING
)
237 /* If there are previously written bytes from a write with
238 ADVANCE="no", add a record marker before performing the
241 if (u
->previous_nonadvancing_write
)
242 finish_last_advance_record (u
);
244 u
->previous_nonadvancing_write
= 0;
251 if (u
->flags
.form
== FORM_FORMATTED
)
252 formatted_backspace (fpp
, u
);
254 unformatted_backspace (fpp
, u
);
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);
310 u
->endfile
= AFTER_ENDFILE
;
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;
346 /* Flush the buffers. If we have been writing to the file, the last
347 written record is the last record in the file, so truncate the
348 file now. Reset to read mode so two consecutive rewind
349 statements do not delete the file contents. */
351 if (u
->mode
== WRITING
&& u
->flags
.access
!= ACCESS_STREAM
)
357 if (file_position (u
->s
) != 0 && sseek (u
->s
, 0) == FAILURE
)
358 generate_error (&fpp
->common
, LIBERROR_OS
, NULL
);
360 /* Handle special files like /dev/null differently. */
361 if (!is_special (u
->s
))
363 /* We are rewinding so we are not at the end. */
364 u
->endfile
= NO_ENDFILE
;
368 /* Set this for compatibilty with g77 for /dev/null. */
369 if (file_length (u
->s
) == 0 && file_position (u
->s
) == 0)
370 u
->endfile
= AT_ENDFILE
;
371 /* Future refinements on special files can go here. */
374 u
->current_record
= 0;
378 /* Update position for INQUIRE. */
379 u
->flags
.position
= POSITION_REWIND
;
387 extern void st_flush (st_parameter_filepos
*);
388 export_proto(st_flush
);
391 st_flush (st_parameter_filepos
*fpp
)
395 library_start (&fpp
->common
);
397 u
= find_unit (fpp
->common
.unit
);
404 /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
405 generate_error (&fpp
->common
, LIBERROR_BAD_OPTION
,
406 "Specified UNIT in FLUSH is not connected");