1 /* Copyright (C) 2002-2003, 2005, 2006 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. */
32 #include "libgfortran.h"
35 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
36 ENDFILE, and REWIND as well as the FLUSH statement. */
39 /* formatted_backspace(fpp, u)-- Move the file back one line. The
40 current position is after the newline that terminates the previous
41 record, and we have to sift backwards to find the newline before
42 that or the start of the file, whichever comes first. */
44 #define READ_CHUNK 4096
47 formatted_backspace (st_parameter_filepos
*fpp
, gfc_unit
*u
)
53 base
= file_position (u
->s
) - 1;
57 n
= (base
< READ_CHUNK
) ? base
: READ_CHUNK
;
60 p
= salloc_r_at (u
->s
, &n
, base
);
64 /* We have moved backwards from the current position, it should
65 not be possible to get a short read. Because it is not
66 clear what to do about such thing, we ignore the possibility. */
68 /* There is no memrchr() in the C library, so we have to do it
85 /* base is the new pointer. Seek to it exactly. */
87 if (sseek (u
->s
, base
) == FAILURE
)
90 u
->endfile
= NO_ENDFILE
;
95 generate_error (&fpp
->common
, ERROR_OS
, NULL
);
99 /* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
100 sequential file. We are guaranteed to be between records on entry and
101 we have to shift to the previous record. */
104 unformatted_backspace (st_parameter_filepos
*fpp
, gfc_unit
*u
)
109 int length
, length_read
;
112 if (compile_options
.record_marker
== 0)
113 length
= sizeof (gfc_offset
);
115 length
= compile_options
.record_marker
;
117 length_read
= length
;
119 p
= salloc_r_at (u
->s
, &length_read
,
120 file_position (u
->s
) - length
);
121 if (p
== NULL
|| length_read
!= length
)
124 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
125 if (u
->flags
.convert
== CONVERT_NATIVE
)
127 switch (compile_options
.record_marker
)
130 memcpy (&m
, p
, sizeof(gfc_offset
));
133 case sizeof(GFC_INTEGER_4
):
134 memcpy (&m4
, p
, sizeof (m4
));
138 case sizeof(GFC_INTEGER_8
):
139 memcpy (&m8
, p
, sizeof (m8
));
144 runtime_error ("Illegal value for record marker");
150 switch (compile_options
.record_marker
)
153 reverse_memcpy (&m
, p
, sizeof(gfc_offset
));
156 case sizeof(GFC_INTEGER_4
):
157 reverse_memcpy (&m4
, p
, sizeof (m4
));
161 case sizeof(GFC_INTEGER_8
):
162 reverse_memcpy (&m8
, p
, sizeof (m8
));
167 runtime_error ("Illegal value for record marker");
173 if ((new = file_position (u
->s
) - m
- 2*length
) < 0)
176 if (sseek (u
->s
, new) == FAILURE
)
183 generate_error (&fpp
->common
, ERROR_OS
, NULL
);
187 extern void st_backspace (st_parameter_filepos
*);
188 export_proto(st_backspace
);
191 st_backspace (st_parameter_filepos
*fpp
)
195 library_start (&fpp
->common
);
197 u
= find_unit (fpp
->common
.unit
);
200 generate_error (&fpp
->common
, ERROR_BAD_UNIT
, NULL
);
204 /* Ignore direct access. Non-advancing I/O is only allowed for formatted
205 sequential I/O and the next direct access transfer repositions the file
208 if (u
->flags
.access
== ACCESS_DIRECT
)
211 /* Check for special cases involving the ENDFILE record first. */
213 if (u
->endfile
== AFTER_ENDFILE
)
215 u
->endfile
= AT_ENDFILE
;
221 if (file_position (u
->s
) == 0)
222 goto done
; /* Common special case */
224 if (u
->mode
== WRITING
)
231 if (u
->flags
.form
== FORM_FORMATTED
)
232 formatted_backspace (fpp
, u
);
234 unformatted_backspace (fpp
, u
);
236 u
->endfile
= NO_ENDFILE
;
237 u
->current_record
= 0;
249 extern void st_endfile (st_parameter_filepos
*);
250 export_proto(st_endfile
);
253 st_endfile (st_parameter_filepos
*fpp
)
257 library_start (&fpp
->common
);
259 u
= find_unit (fpp
->common
.unit
);
262 if (u
->current_record
)
265 dtp
.common
= fpp
->common
;
266 memset (&dtp
.u
.p
, 0, sizeof (dtp
.u
.p
));
267 dtp
.u
.p
.current_unit
= u
;
268 next_record (&dtp
, 1);
273 u
->endfile
= AFTER_ENDFILE
;
281 extern void st_rewind (st_parameter_filepos
*);
282 export_proto(st_rewind
);
285 st_rewind (st_parameter_filepos
*fpp
)
289 library_start (&fpp
->common
);
291 u
= find_unit (fpp
->common
.unit
);
294 if (u
->flags
.access
!= ACCESS_SEQUENTIAL
)
295 generate_error (&fpp
->common
, ERROR_BAD_OPTION
,
296 "Cannot REWIND a file opened for DIRECT access");
299 /* Flush the buffers. If we have been writing to the file, the last
300 written record is the last record in the file, so truncate the
301 file now. Reset to read mode so two consecutive rewind
302 statements do not delete the file contents. */
304 if (u
->mode
== WRITING
)
309 if (sseek (u
->s
, 0) == FAILURE
)
310 generate_error (&fpp
->common
, ERROR_OS
, NULL
);
312 u
->endfile
= NO_ENDFILE
;
313 u
->current_record
= 0;
318 /* Update position for INQUIRE. */
319 u
->flags
.position
= POSITION_REWIND
;
327 extern void st_flush (st_parameter_filepos
*);
328 export_proto(st_flush
);
331 st_flush (st_parameter_filepos
*fpp
)
335 library_start (&fpp
->common
);
337 u
= find_unit (fpp
->common
.unit
);