1 /* Copyright (C) 2002-2016 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist transfer functions contributed by Paul Thomas
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
28 /* transfer.c -- Top level handling of data transfer statements. */
40 /* Calling conventions: Data transfer statements are unlike other
41 library calls in that they extend over several calls.
43 The first call is always a call to st_read() or st_write(). These
44 subroutines return no status unless a namelist read or write is
45 being done, in which case there is the usual status. No further
46 calls are necessary in this case.
48 For other sorts of data transfer, there are zero or more data
49 transfer statement that depend on the format of the data transfer
50 statement. For READ (and for backwards compatibily: for WRITE), one has
55 transfer_character_wide
63 transfer_integer_write
64 transfer_logical_write
65 transfer_character_write
66 transfer_character_wide_write
68 transfer_complex_write
69 transfer_real128_write
70 transfer_complex128_write
72 These subroutines do not return status. The *128 functions
73 are in the file transfer128.c.
75 The last call is a call to st_[read|write]_done(). While
76 something can easily go wrong with the initial st_read() or
77 st_write(), an error inhibits any data from actually being
80 extern void transfer_integer (st_parameter_dt
*, void *, int);
81 export_proto(transfer_integer
);
83 extern void transfer_integer_write (st_parameter_dt
*, void *, int);
84 export_proto(transfer_integer_write
);
86 extern void transfer_real (st_parameter_dt
*, void *, int);
87 export_proto(transfer_real
);
89 extern void transfer_real_write (st_parameter_dt
*, void *, int);
90 export_proto(transfer_real_write
);
92 extern void transfer_logical (st_parameter_dt
*, void *, int);
93 export_proto(transfer_logical
);
95 extern void transfer_logical_write (st_parameter_dt
*, void *, int);
96 export_proto(transfer_logical_write
);
98 extern void transfer_character (st_parameter_dt
*, void *, int);
99 export_proto(transfer_character
);
101 extern void transfer_character_write (st_parameter_dt
*, void *, int);
102 export_proto(transfer_character_write
);
104 extern void transfer_character_wide (st_parameter_dt
*, void *, int, int);
105 export_proto(transfer_character_wide
);
107 extern void transfer_character_wide_write (st_parameter_dt
*,
109 export_proto(transfer_character_wide_write
);
111 extern void transfer_complex (st_parameter_dt
*, void *, int);
112 export_proto(transfer_complex
);
114 extern void transfer_complex_write (st_parameter_dt
*, void *, int);
115 export_proto(transfer_complex_write
);
117 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
119 export_proto(transfer_array
);
121 extern void transfer_array_write (st_parameter_dt
*, gfc_array_char
*, int,
123 export_proto(transfer_array_write
);
125 /* User defined derived type input/output. */
127 transfer_derived (st_parameter_dt
*dtp
, void *dtio_source
, void *dtio_proc
);
128 export_proto(transfer_derived
);
131 transfer_derived_write (st_parameter_dt
*dtp
, void *dtio_source
, void *dtio_proc
);
132 export_proto(transfer_derived_write
);
134 static void us_read (st_parameter_dt
*, int);
135 static void us_write (st_parameter_dt
*, int);
136 static void next_record_r_unf (st_parameter_dt
*, int);
137 static void next_record_w_unf (st_parameter_dt
*, int);
139 static const st_option advance_opt
[] = {
140 {"yes", ADVANCE_YES
},
146 static const st_option decimal_opt
[] = {
147 {"point", DECIMAL_POINT
},
148 {"comma", DECIMAL_COMMA
},
152 static const st_option round_opt
[] = {
154 {"down", ROUND_DOWN
},
155 {"zero", ROUND_ZERO
},
156 {"nearest", ROUND_NEAREST
},
157 {"compatible", ROUND_COMPATIBLE
},
158 {"processor_defined", ROUND_PROCDEFINED
},
163 static const st_option sign_opt
[] = {
165 {"suppress", SIGN_SS
},
166 {"processor_defined", SIGN_S
},
170 static const st_option blank_opt
[] = {
171 {"null", BLANK_NULL
},
172 {"zero", BLANK_ZERO
},
176 static const st_option delim_opt
[] = {
177 {"apostrophe", DELIM_APOSTROPHE
},
178 {"quote", DELIM_QUOTE
},
179 {"none", DELIM_NONE
},
183 static const st_option pad_opt
[] = {
190 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
191 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
197 current_mode (st_parameter_dt
*dtp
)
201 m
= FORM_UNSPECIFIED
;
203 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
205 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
206 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
208 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
210 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
211 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
213 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
215 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
216 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
223 /* Mid level data transfer statements. */
225 /* Read sequential file - internal unit */
228 read_sf_internal (st_parameter_dt
*dtp
, int * length
)
230 static char *empty_string
[0];
234 /* Zero size array gives internal unit len of 0. Nothing to read. */
235 if (dtp
->internal_unit_len
== 0
236 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
239 /* If we have seen an eor previously, return a length of 0. The
240 caller is responsible for correctly padding the input field. */
241 if (dtp
->u
.p
.sf_seen_eor
)
244 /* Just return something that isn't a NULL pointer, otherwise the
245 caller thinks an error occurred. */
246 return (char*) empty_string
;
250 if (is_char4_unit(dtp
))
253 gfc_char4_t
*p
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
,
255 base
= fbuf_alloc (dtp
->u
.p
.current_unit
, lorig
);
256 for (i
= 0; i
< *length
; i
++, p
++)
257 base
[i
] = *p
> 255 ? '?' : (unsigned char) *p
;
260 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
262 if (unlikely (lorig
> *length
))
268 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
270 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
271 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *length
;
277 /* When reading sequential formatted records we have a problem. We
278 don't know how long the line is until we read the trailing newline,
279 and we don't want to read too much. If we read too much, we might
280 have to do a physical seek backwards depending on how much data is
281 present, and devices like terminals aren't seekable and would cause
284 Given this, the solution is to read a byte at a time, stopping if
285 we hit the newline. For small allocations, we use a static buffer.
286 For larger allocations, we are forced to allocate memory on the
287 heap. Hopefully this won't happen very often. */
289 /* Read sequential file - external unit */
292 read_sf (st_parameter_dt
*dtp
, int * length
)
294 static char *empty_string
[0];
296 int n
, lorig
, seen_comma
;
298 /* If we have seen an eor previously, return a length of 0. The
299 caller is responsible for correctly padding the input field. */
300 if (dtp
->u
.p
.sf_seen_eor
)
303 /* Just return something that isn't a NULL pointer, otherwise the
304 caller thinks an error occurred. */
305 return (char*) empty_string
;
310 /* Read data into format buffer and scan through it. */
315 q
= fbuf_getc (dtp
->u
.p
.current_unit
);
318 else if (q
== '\n' || q
== '\r')
320 /* Unexpected end of line. Set the position. */
321 dtp
->u
.p
.sf_seen_eor
= 1;
323 /* If we see an EOR during non-advancing I/O, we need to skip
324 the rest of the I/O statement. Set the corresponding flag. */
325 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
326 dtp
->u
.p
.eor_condition
= 1;
328 /* If we encounter a CR, it might be a CRLF. */
329 if (q
== '\r') /* Probably a CRLF */
331 /* See if there is an LF. */
332 q2
= fbuf_getc (dtp
->u
.p
.current_unit
);
334 dtp
->u
.p
.sf_seen_eor
= 2;
335 else if (q2
!= EOF
) /* Oops, seek back. */
336 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
339 /* Without padding, terminate the I/O statement without assigning
340 the value. With padding, the value still needs to be assigned,
341 so we can just continue with a short read. */
342 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
344 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
351 /* Short circuit the read if a comma is found during numeric input.
352 The flag is set to zero during character reads so that commas in
353 strings are not ignored */
355 if (dtp
->u
.p
.sf_read_comma
== 1)
358 notify_std (&dtp
->common
, GFC_STD_GNU
,
359 "Comma in formatted numeric read.");
367 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
368 some other stuff. Set the relevant flags. */
369 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
373 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
375 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
381 dtp
->u
.p
.eor_condition
= 1;
386 else if (dtp
->u
.p
.advance_status
== ADVANCE_NO
387 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
388 || dtp
->u
.p
.current_unit
->bytes_left
389 == dtp
->u
.p
.current_unit
->recl
)
398 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
400 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
401 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) n
;
403 /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
404 fbuf_getc might reallocate the buffer. So return current pointer
405 minus all the advances, which is n plus up to two characters
406 of newline or comma. */
407 return fbuf_getptr (dtp
->u
.p
.current_unit
)
408 - n
- dtp
->u
.p
.sf_seen_eor
- seen_comma
;
412 /* Function for reading the next couple of bytes from the current
413 file, advancing the current position. We return NULL on end of record or
414 end of file. This function is only for formatted I/O, unformatted uses
417 If the read is short, then it is because the current record does not
418 have enough data to satisfy the read request and the file was
419 opened with PAD=YES. The caller must assume tailing spaces for
423 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
428 if (!is_stream_io (dtp
))
430 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
432 /* For preconnected units with default record length, set bytes left
433 to unit record length and proceed, otherwise error. */
434 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
435 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
436 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
439 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
440 && !is_internal_unit (dtp
))
442 /* Not enough data left. */
443 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
448 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0
449 && !is_internal_unit(dtp
)))
455 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
459 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
460 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
461 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
463 if (is_internal_unit (dtp
))
464 source
= read_sf_internal (dtp
, nbytes
);
466 source
= read_sf (dtp
, nbytes
);
468 dtp
->u
.p
.current_unit
->strm_pos
+=
469 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
473 /* If we reach here, we can assume it's direct access. */
475 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
478 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
479 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
481 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
482 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *nbytes
;
484 if (norig
!= *nbytes
)
486 /* Short read, this shouldn't happen. */
487 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
489 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
494 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
500 /* Read a block from a character(kind=4) internal unit, to be transferred into
501 a character(kind=4) variable. Note: Portions of this code borrowed from
504 read_block_form4 (st_parameter_dt
*dtp
, int * nbytes
)
506 static gfc_char4_t
*empty_string
[0];
510 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
511 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
513 /* Zero size array gives internal unit len of 0. Nothing to read. */
514 if (dtp
->internal_unit_len
== 0
515 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
518 /* If we have seen an eor previously, return a length of 0. The
519 caller is responsible for correctly padding the input field. */
520 if (dtp
->u
.p
.sf_seen_eor
)
523 /* Just return something that isn't a NULL pointer, otherwise the
524 caller thinks an error occurred. */
529 source
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
, nbytes
);
531 if (unlikely (lorig
> *nbytes
))
537 dtp
->u
.p
.current_unit
->bytes_left
-= *nbytes
;
539 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
540 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *nbytes
;
546 /* Reads a block directly into application data space. This is for
547 unformatted files. */
550 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
552 ssize_t to_read_record
;
553 ssize_t have_read_record
;
554 ssize_t to_read_subrecord
;
555 ssize_t have_read_subrecord
;
558 if (is_stream_io (dtp
))
560 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
562 if (unlikely (have_read_record
< 0))
564 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
568 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
570 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
572 /* Short read, e.g. if we hit EOF. For stream files,
573 we have to set the end-of-file condition. */
579 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
581 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
584 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
585 nbytes
= to_read_record
;
590 to_read_record
= nbytes
;
593 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
595 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
596 if (unlikely (to_read_record
< 0))
598 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
602 if (to_read_record
!= (ssize_t
) nbytes
)
604 /* Short read, e.g. if we hit EOF. Apparently, we read
605 more than was written to the last record. */
609 if (unlikely (short_record
))
611 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
616 /* Unformatted sequential. We loop over the subrecords, reading
617 until the request has been fulfilled or the record has run out
618 of continuation subrecords. */
620 /* Check whether we exceed the total record length. */
622 if (dtp
->u
.p
.current_unit
->flags
.has_recl
623 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
625 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
630 to_read_record
= nbytes
;
633 have_read_record
= 0;
637 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
638 < (gfc_offset
) to_read_record
)
640 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
641 to_read_record
-= to_read_subrecord
;
645 to_read_subrecord
= to_read_record
;
649 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
651 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
652 buf
+ have_read_record
, to_read_subrecord
);
653 if (unlikely (have_read_subrecord
< 0))
655 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
659 have_read_record
+= have_read_subrecord
;
661 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
663 /* Short read, e.g. if we hit EOF. This means the record
664 structure has been corrupted, or the trailing record
665 marker would still be present. */
667 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
671 if (to_read_record
> 0)
673 if (likely (dtp
->u
.p
.current_unit
->continued
))
675 next_record_r_unf (dtp
, 0);
680 /* Let's make sure the file position is correctly pre-positioned
681 for the next read statement. */
683 dtp
->u
.p
.current_unit
->current_record
= 0;
684 next_record_r_unf (dtp
, 0);
685 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
691 /* Normal exit, the read request has been fulfilled. */
696 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
697 if (unlikely (short_record
))
699 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
706 /* Function for writing a block of bytes to the current file at the
707 current position, advancing the file pointer. We are given a length
708 and return a pointer to a buffer that the caller must (completely)
709 fill in. Returns NULL on error. */
712 write_block (st_parameter_dt
*dtp
, int length
)
716 if (!is_stream_io (dtp
))
718 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
720 /* For preconnected units with default record length, set bytes left
721 to unit record length and proceed, otherwise error. */
722 if (likely ((dtp
->u
.p
.current_unit
->unit_number
723 == options
.stdout_unit
724 || dtp
->u
.p
.current_unit
->unit_number
725 == options
.stderr_unit
)
726 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
727 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
730 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
735 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
738 if (is_internal_unit (dtp
))
740 if (dtp
->common
.unit
) /* char4 internel unit. */
743 dest4
= mem_alloc_w4 (dtp
->u
.p
.current_unit
->s
, &length
);
746 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
752 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
756 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
760 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
761 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
765 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
768 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
773 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
774 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) length
;
776 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
782 /* High level interface to swrite(), taking care of errors. This is only
783 called for unformatted files. There are three cases to consider:
784 Stream I/O, unformatted direct, unformatted sequential. */
787 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
790 ssize_t have_written
;
791 ssize_t to_write_subrecord
;
796 if (is_stream_io (dtp
))
798 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
799 if (unlikely (have_written
< 0))
801 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
805 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
810 /* Unformatted direct access. */
812 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
814 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
816 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
820 if (buf
== NULL
&& nbytes
== 0)
823 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
824 if (unlikely (have_written
< 0))
826 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
830 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
831 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
836 /* Unformatted sequential. */
840 if (dtp
->u
.p
.current_unit
->flags
.has_recl
841 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
843 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
855 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
856 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
858 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
859 (gfc_offset
) to_write_subrecord
;
861 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
862 buf
+ have_written
, to_write_subrecord
);
863 if (unlikely (to_write_subrecord
< 0))
865 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
869 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
870 nbytes
-= to_write_subrecord
;
871 have_written
+= to_write_subrecord
;
876 next_record_w_unf (dtp
, 1);
879 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
880 if (unlikely (short_record
))
882 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
889 /* Reverse memcpy - used for byte swapping. */
892 reverse_memcpy (void *dest
, const void *src
, size_t n
)
898 s
= (char *) src
+ n
- 1;
900 /* Write with ascending order - this is likely faster
901 on modern architectures because of write combining. */
907 /* Utility function for byteswapping an array, using the bswap
908 builtins if possible. dest and src can overlap completely, or then
909 they must point to separate objects; partial overlaps are not
913 bswap_array (void *dest
, const void *src
, size_t size
, size_t nelems
)
923 for (size_t i
= 0; i
< nelems
; i
++)
924 ((uint16_t*)dest
)[i
] = __builtin_bswap16 (((uint16_t*)src
)[i
]);
927 for (size_t i
= 0; i
< nelems
; i
++)
928 ((uint32_t*)dest
)[i
] = __builtin_bswap32 (((uint32_t*)src
)[i
]);
931 for (size_t i
= 0; i
< nelems
; i
++)
932 ((uint64_t*)dest
)[i
] = __builtin_bswap64 (((uint64_t*)src
)[i
]);
937 for (size_t i
= 0; i
< nelems
; i
++)
940 memcpy (&tmp
, ps
, 4);
941 *(uint32_t*)pd
= __builtin_bswap32 (*(uint32_t*)(ps
+ 8));
942 *(uint32_t*)(pd
+ 4) = __builtin_bswap32 (*(uint32_t*)(ps
+ 4));
943 *(uint32_t*)(pd
+ 8) = __builtin_bswap32 (tmp
);
951 for (size_t i
= 0; i
< nelems
; i
++)
954 memcpy (&tmp
, ps
, 8);
955 *(uint64_t*)pd
= __builtin_bswap64 (*(uint64_t*)(ps
+ 8));
956 *(uint64_t*)(pd
+ 8) = __builtin_bswap64 (tmp
);
966 for (size_t i
= 0; i
< nelems
; i
++)
968 reverse_memcpy (pd
, ps
, size
);
975 /* In-place byte swap. */
976 for (size_t i
= 0; i
< nelems
; i
++)
978 char tmp
, *low
= pd
, *high
= pd
+ size
- 1;
979 for (size_t j
= 0; j
< size
/2; j
++)
994 /* Master function for unformatted reads. */
997 unformatted_read (st_parameter_dt
*dtp
, bt type
,
998 void *dest
, int kind
, size_t size
, size_t nelems
)
1000 if (type
== BT_CLASS
)
1002 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1003 char tmp_iomsg
[IOMSG_LEN
] = "";
1005 gfc_charlen_type child_iomsg_len
;
1007 int *child_iostat
= NULL
;
1009 /* Set iostat, intent(out). */
1011 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1012 dtp
->common
.iostat
: &noiostat
;
1014 /* Set iomsg, intent(inout). */
1015 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1017 child_iomsg
= dtp
->common
.iomsg
;
1018 child_iomsg_len
= dtp
->common
.iomsg_len
;
1022 child_iomsg
= tmp_iomsg
;
1023 child_iomsg_len
= IOMSG_LEN
;
1026 /* Call the user defined unformatted READ procedure. */
1027 dtp
->u
.p
.current_unit
->child_dtio
++;
1028 dtp
->u
.p
.ufdtio_ptr (dest
, &unit
, child_iostat
, child_iomsg
,
1030 dtp
->u
.p
.current_unit
->child_dtio
--;
1034 if (type
== BT_CHARACTER
)
1035 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
1036 read_block_direct (dtp
, dest
, size
* nelems
);
1038 if (unlikely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_SWAP
)
1041 /* Handle wide chracters. */
1042 if (type
== BT_CHARACTER
)
1048 /* Break up complex into its constituent reals. */
1049 else if (type
== BT_COMPLEX
)
1054 bswap_array (dest
, dest
, size
, nelems
);
1059 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
1060 bytes on 64 bit machines. The unused bytes are not initialized and never
1061 used, which can show an error with memory checking analyzers like
1062 valgrind. We us BT_CLASS to denote a User Defined I/O call. */
1065 unformatted_write (st_parameter_dt
*dtp
, bt type
,
1066 void *source
, int kind
, size_t size
, size_t nelems
)
1068 if (type
== BT_CLASS
)
1070 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1071 char tmp_iomsg
[IOMSG_LEN
] = "";
1073 gfc_charlen_type child_iomsg_len
;
1075 int *child_iostat
= NULL
;
1077 /* Set iostat, intent(out). */
1079 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1080 dtp
->common
.iostat
: &noiostat
;
1082 /* Set iomsg, intent(inout). */
1083 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1085 child_iomsg
= dtp
->common
.iomsg
;
1086 child_iomsg_len
= dtp
->common
.iomsg_len
;
1090 child_iomsg
= tmp_iomsg
;
1091 child_iomsg_len
= IOMSG_LEN
;
1094 /* Call the user defined unformatted WRITE procedure. */
1095 dtp
->u
.p
.current_unit
->child_dtio
++;
1096 dtp
->u
.p
.ufdtio_ptr (source
, &unit
, child_iostat
, child_iomsg
,
1098 dtp
->u
.p
.current_unit
->child_dtio
--;
1102 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1105 size_t stride
= type
== BT_CHARACTER
?
1106 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1108 write_buf (dtp
, source
, stride
* nelems
);
1112 #define BSWAP_BUFSZ 512
1113 char buffer
[BSWAP_BUFSZ
];
1119 /* Handle wide chracters. */
1120 if (type
== BT_CHARACTER
&& kind
!= 1)
1126 /* Break up complex into its constituent reals. */
1127 if (type
== BT_COMPLEX
)
1133 /* By now, all complex variables have been split into their
1134 constituent reals. */
1140 if (size
* nrem
> BSWAP_BUFSZ
)
1141 nc
= BSWAP_BUFSZ
/ size
;
1145 bswap_array (buffer
, p
, size
, nc
);
1146 write_buf (dtp
, buffer
, size
* nc
);
1155 /* Return a pointer to the name of a type. */
1180 p
= "CLASS or DERIVED";
1183 internal_error (NULL
, "type_name(): Bad type");
1190 /* Write a constant string to the output.
1191 This is complicated because the string can have doubled delimiters
1192 in it. The length in the format node is the true length. */
1195 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
1197 char c
, delimiter
, *p
, *q
;
1200 length
= f
->u
.string
.length
;
1204 p
= write_block (dtp
, length
);
1211 for (; length
> 0; length
--)
1214 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
1215 q
++; /* Skip the doubled delimiter. */
1220 /* Given actual and expected types in a formatted data transfer, make
1221 sure they agree. If not, an error message is generated. Returns
1222 nonzero if something went wrong. */
1225 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
1228 char buffer
[BUFLEN
];
1230 if (actual
== expected
)
1233 /* Adjust item_count before emitting error message. */
1234 snprintf (buffer
, BUFLEN
,
1235 "Expected %s for item %d in formatted transfer, got %s",
1236 type_name (expected
), dtp
->u
.p
.item_count
- 1, type_name (actual
));
1238 format_error (dtp
, f
, buffer
);
1244 require_numeric_type (st_parameter_dt
*dtp
, bt actual
, const fnode
*f
)
1247 char buffer
[BUFLEN
];
1249 if (actual
== BT_INTEGER
|| actual
== BT_REAL
|| actual
== BT_COMPLEX
)
1252 /* Adjust item_count before emitting error message. */
1253 snprintf (buffer
, BUFLEN
,
1254 "Expected numeric type for item %d in formatted transfer, got %s",
1255 dtp
->u
.p
.item_count
- 1, type_name (actual
));
1257 format_error (dtp
, f
, buffer
);
1262 /* This function is in the main loop for a formatted data transfer
1263 statement. It would be natural to implement this as a coroutine
1264 with the user program, but C makes that awkward. We loop,
1265 processing format elements. When we actually have to transfer
1266 data instead of just setting flags, we return control to the user
1267 program which calls a function that supplies the address and type
1268 of the next element, then comes back here to process it. */
1271 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1274 int pos
, bytes_used
;
1278 int consume_data_flag
;
1280 /* Change a complex data item into a pair of reals. */
1282 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1283 if (type
== BT_COMPLEX
)
1289 /* If there's an EOR condition, we simulate finalizing the transfer
1290 by doing nothing. */
1291 if (dtp
->u
.p
.eor_condition
)
1294 /* Set this flag so that commas in reads cause the read to complete before
1295 the entire field has been read. The next read field will start right after
1296 the comma in the stream. (Set to 0 for character reads). */
1297 dtp
->u
.p
.sf_read_comma
=
1298 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1302 /* If reversion has occurred and there is another real data item,
1303 then we have to move to the next record. */
1304 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1306 dtp
->u
.p
.reversion_flag
= 0;
1307 next_record (dtp
, 0);
1310 consume_data_flag
= 1;
1311 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1314 f
= next_format (dtp
);
1317 /* No data descriptors left. */
1318 if (unlikely (n
> 0))
1319 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1320 "Insufficient data descriptors in format after reversion");
1326 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1327 - dtp
->u
.p
.current_unit
->bytes_left
);
1329 if (is_stream_io(dtp
))
1336 goto need_read_data
;
1337 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1339 read_decimal (dtp
, f
, p
, kind
);
1344 goto need_read_data
;
1345 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1346 && require_numeric_type (dtp
, type
, f
))
1348 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1349 && require_type (dtp
, BT_INTEGER
, type
, f
))
1351 read_radix (dtp
, f
, p
, kind
, 2);
1356 goto need_read_data
;
1357 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1358 && require_numeric_type (dtp
, type
, f
))
1360 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1361 && require_type (dtp
, BT_INTEGER
, type
, f
))
1363 read_radix (dtp
, f
, p
, kind
, 8);
1368 goto need_read_data
;
1369 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1370 && require_numeric_type (dtp
, type
, f
))
1372 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1373 && require_type (dtp
, BT_INTEGER
, type
, f
))
1375 read_radix (dtp
, f
, p
, kind
, 16);
1380 goto need_read_data
;
1382 /* It is possible to have FMT_A with something not BT_CHARACTER such
1383 as when writing out hollerith strings, so check both type
1384 and kind before calling wide character routines. */
1385 if (type
== BT_CHARACTER
&& kind
== 4)
1386 read_a_char4 (dtp
, f
, p
, size
);
1388 read_a (dtp
, f
, p
, size
);
1393 goto need_read_data
;
1394 read_l (dtp
, f
, p
, kind
);
1399 goto need_read_data
;
1400 if (require_type (dtp
, BT_REAL
, type
, f
))
1402 read_f (dtp
, f
, p
, kind
);
1407 goto need_read_data
;
1408 if (require_type (dtp
, BT_CLASS
, type
, f
))
1410 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1412 char tmp_iomsg
[IOMSG_LEN
] = "";
1414 gfc_charlen_type child_iomsg_len
;
1416 int *child_iostat
= NULL
;
1417 char *iotype
= f
->u
.udf
.string
;
1418 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1420 /* Build the iotype string. */
1421 if (iotype_len
== 0)
1429 iotype
= xmalloc (iotype_len
);
1432 memcpy (iotype
+ 2, f
->u
.udf
.string
, f
->u
.udf
.string_len
);
1435 /* Set iostat, intent(out). */
1437 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1438 dtp
->common
.iostat
: &noiostat
;
1440 /* Set iomsg, intent(inout). */
1441 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1443 child_iomsg
= dtp
->common
.iomsg
;
1444 child_iomsg_len
= dtp
->common
.iomsg_len
;
1448 child_iomsg
= tmp_iomsg
;
1449 child_iomsg_len
= IOMSG_LEN
;
1452 /* Call the user defined formatted READ procedure. */
1453 dtp
->u
.p
.current_unit
->child_dtio
++;
1454 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1455 child_iostat
, child_iomsg
,
1456 iotype_len
, child_iomsg_len
);
1457 dtp
->u
.p
.current_unit
->child_dtio
--;
1459 if (f
->u
.udf
.string_len
!= 0)
1461 /* Note: vlist is freed in free_format_data. */
1466 goto need_read_data
;
1467 if (require_type (dtp
, BT_REAL
, type
, f
))
1469 read_f (dtp
, f
, p
, kind
);
1474 goto need_read_data
;
1475 if (require_type (dtp
, BT_REAL
, type
, f
))
1477 read_f (dtp
, f
, p
, kind
);
1482 goto need_read_data
;
1483 if (require_type (dtp
, BT_REAL
, type
, f
))
1485 read_f (dtp
, f
, p
, kind
);
1490 goto need_read_data
;
1491 if (require_type (dtp
, BT_REAL
, type
, f
))
1493 read_f (dtp
, f
, p
, kind
);
1498 goto need_read_data
;
1502 read_decimal (dtp
, f
, p
, kind
);
1505 read_l (dtp
, f
, p
, kind
);
1509 read_a_char4 (dtp
, f
, p
, size
);
1511 read_a (dtp
, f
, p
, size
);
1514 read_f (dtp
, f
, p
, kind
);
1517 internal_error (&dtp
->common
, "formatted_transfer(): Bad type");
1522 consume_data_flag
= 0;
1523 format_error (dtp
, f
, "Constant string in input format");
1526 /* Format codes that don't transfer data. */
1529 consume_data_flag
= 0;
1530 dtp
->u
.p
.skips
+= f
->u
.n
;
1531 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1532 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1533 read_x (dtp
, f
->u
.n
);
1538 consume_data_flag
= 0;
1540 if (f
->format
== FMT_TL
)
1542 /* Handle the special case when no bytes have been used yet.
1543 Cannot go below zero. */
1544 if (bytes_used
== 0)
1546 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1547 dtp
->u
.p
.skips
-= f
->u
.n
;
1548 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1551 pos
= bytes_used
- f
->u
.n
;
1556 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1557 left tab limit. We do not check if the position has gone
1558 beyond the end of record because a subsequent tab could
1559 bring us back again. */
1560 pos
= pos
< 0 ? 0 : pos
;
1562 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1563 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1564 + pos
- dtp
->u
.p
.max_pos
;
1565 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1566 ? 0 : dtp
->u
.p
.pending_spaces
;
1567 if (dtp
->u
.p
.skips
== 0)
1570 /* Adjust everything for end-of-record condition */
1571 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1573 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1574 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1576 dtp
->u
.p
.sf_seen_eor
= 0;
1578 if (dtp
->u
.p
.skips
< 0)
1580 if (is_internal_unit (dtp
))
1581 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1583 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1584 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1585 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1588 read_x (dtp
, dtp
->u
.p
.skips
);
1592 consume_data_flag
= 0;
1593 dtp
->u
.p
.sign_status
= SIGN_S
;
1597 consume_data_flag
= 0;
1598 dtp
->u
.p
.sign_status
= SIGN_SS
;
1602 consume_data_flag
= 0;
1603 dtp
->u
.p
.sign_status
= SIGN_SP
;
1607 consume_data_flag
= 0 ;
1608 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1612 consume_data_flag
= 0;
1613 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1617 consume_data_flag
= 0;
1618 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1622 consume_data_flag
= 0;
1623 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1627 consume_data_flag
= 0;
1628 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1632 consume_data_flag
= 0;
1633 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1637 consume_data_flag
= 0;
1638 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1642 consume_data_flag
= 0;
1643 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1647 consume_data_flag
= 0;
1648 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1652 consume_data_flag
= 0;
1653 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1657 consume_data_flag
= 0;
1658 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1662 consume_data_flag
= 0;
1663 dtp
->u
.p
.seen_dollar
= 1;
1667 consume_data_flag
= 0;
1668 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1669 next_record (dtp
, 0);
1673 /* A colon descriptor causes us to exit this loop (in
1674 particular preventing another / descriptor from being
1675 processed) unless there is another data item to be
1677 consume_data_flag
= 0;
1683 internal_error (&dtp
->common
, "Bad format node");
1686 /* Adjust the item count and data pointer. */
1688 if ((consume_data_flag
> 0) && (n
> 0))
1691 p
= ((char *) p
) + size
;
1696 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1697 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1702 /* Come here when we need a data descriptor but don't have one. We
1703 push the current format node back onto the input, then return and
1704 let the user program call us back with the data. */
1706 unget_format (dtp
, f
);
1711 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1714 int pos
, bytes_used
;
1718 int consume_data_flag
;
1720 /* Change a complex data item into a pair of reals. */
1722 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1723 if (type
== BT_COMPLEX
)
1729 /* If there's an EOR condition, we simulate finalizing the transfer
1730 by doing nothing. */
1731 if (dtp
->u
.p
.eor_condition
)
1734 /* Set this flag so that commas in reads cause the read to complete before
1735 the entire field has been read. The next read field will start right after
1736 the comma in the stream. (Set to 0 for character reads). */
1737 dtp
->u
.p
.sf_read_comma
=
1738 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1742 /* If reversion has occurred and there is another real data item,
1743 then we have to move to the next record. */
1744 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1746 dtp
->u
.p
.reversion_flag
= 0;
1747 next_record (dtp
, 0);
1750 consume_data_flag
= 1;
1751 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1754 f
= next_format (dtp
);
1757 /* No data descriptors left. */
1758 if (unlikely (n
> 0))
1759 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1760 "Insufficient data descriptors in format after reversion");
1764 /* Now discharge T, TR and X movements to the right. This is delayed
1765 until a data producing format to suppress trailing spaces. */
1768 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1769 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1770 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1771 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1772 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
1774 || t
== FMT_STRING
))
1776 if (dtp
->u
.p
.skips
> 0)
1779 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1780 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1781 - dtp
->u
.p
.current_unit
->bytes_left
);
1783 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1786 if (dtp
->u
.p
.skips
< 0)
1788 if (is_internal_unit (dtp
))
1789 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1791 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1792 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1794 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1797 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1798 - dtp
->u
.p
.current_unit
->bytes_left
);
1800 if (is_stream_io(dtp
))
1808 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1810 write_i (dtp
, f
, p
, kind
);
1816 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1817 && require_numeric_type (dtp
, type
, f
))
1819 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1820 && require_type (dtp
, BT_INTEGER
, type
, f
))
1822 write_b (dtp
, f
, p
, kind
);
1828 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1829 && require_numeric_type (dtp
, type
, f
))
1831 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1832 && require_type (dtp
, BT_INTEGER
, type
, f
))
1834 write_o (dtp
, f
, p
, kind
);
1840 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1841 && require_numeric_type (dtp
, type
, f
))
1843 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1844 && require_type (dtp
, BT_INTEGER
, type
, f
))
1846 write_z (dtp
, f
, p
, kind
);
1853 /* It is possible to have FMT_A with something not BT_CHARACTER such
1854 as when writing out hollerith strings, so check both type
1855 and kind before calling wide character routines. */
1856 if (type
== BT_CHARACTER
&& kind
== 4)
1857 write_a_char4 (dtp
, f
, p
, size
);
1859 write_a (dtp
, f
, p
, size
);
1865 write_l (dtp
, f
, p
, kind
);
1871 if (require_type (dtp
, BT_REAL
, type
, f
))
1873 write_d (dtp
, f
, p
, kind
);
1879 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1881 char tmp_iomsg
[IOMSG_LEN
] = "";
1883 gfc_charlen_type child_iomsg_len
;
1885 int *child_iostat
= NULL
;
1886 char *iotype
= f
->u
.udf
.string
;
1887 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1889 /* Build the iotype string. */
1890 if (iotype_len
== 0)
1898 iotype
= xmalloc (iotype_len
);
1901 memcpy (iotype
+ 2, f
->u
.udf
.string
, f
->u
.udf
.string_len
);
1904 /* Set iostat, intent(out). */
1906 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1907 dtp
->common
.iostat
: &noiostat
;
1909 /* Set iomsg, intent(inout). */
1910 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1912 child_iomsg
= dtp
->common
.iomsg
;
1913 child_iomsg_len
= dtp
->common
.iomsg_len
;
1917 child_iomsg
= tmp_iomsg
;
1918 child_iomsg_len
= IOMSG_LEN
;
1921 /* Call the user defined formatted WRITE procedure. */
1922 dtp
->u
.p
.current_unit
->child_dtio
++;
1923 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1924 child_iostat
, child_iomsg
,
1925 iotype_len
, child_iomsg_len
);
1926 dtp
->u
.p
.current_unit
->child_dtio
--;
1928 if (f
->u
.udf
.string_len
!= 0)
1930 /* Note: vlist is freed in free_format_data. */
1936 if (require_type (dtp
, BT_REAL
, type
, f
))
1938 write_e (dtp
, f
, p
, kind
);
1944 if (require_type (dtp
, BT_REAL
, type
, f
))
1946 write_en (dtp
, f
, p
, kind
);
1952 if (require_type (dtp
, BT_REAL
, type
, f
))
1954 write_es (dtp
, f
, p
, kind
);
1960 if (require_type (dtp
, BT_REAL
, type
, f
))
1962 write_f (dtp
, f
, p
, kind
);
1971 write_i (dtp
, f
, p
, kind
);
1974 write_l (dtp
, f
, p
, kind
);
1978 write_a_char4 (dtp
, f
, p
, size
);
1980 write_a (dtp
, f
, p
, size
);
1983 if (f
->u
.real
.w
== 0)
1984 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1986 write_d (dtp
, f
, p
, kind
);
1989 internal_error (&dtp
->common
,
1990 "formatted_transfer(): Bad type");
1995 consume_data_flag
= 0;
1996 write_constant_string (dtp
, f
);
1999 /* Format codes that don't transfer data. */
2002 consume_data_flag
= 0;
2004 dtp
->u
.p
.skips
+= f
->u
.n
;
2005 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
2006 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
2007 /* Writes occur just before the switch on f->format, above, so
2008 that trailing blanks are suppressed, unless we are doing a
2009 non-advancing write in which case we want to output the blanks
2011 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2013 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
2014 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2020 consume_data_flag
= 0;
2022 if (f
->format
== FMT_TL
)
2025 /* Handle the special case when no bytes have been used yet.
2026 Cannot go below zero. */
2027 if (bytes_used
== 0)
2029 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
2030 dtp
->u
.p
.skips
-= f
->u
.n
;
2031 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
2034 pos
= bytes_used
- f
->u
.n
;
2037 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
2039 /* Standard 10.6.1.1: excessive left tabbing is reset to the
2040 left tab limit. We do not check if the position has gone
2041 beyond the end of record because a subsequent tab could
2042 bring us back again. */
2043 pos
= pos
< 0 ? 0 : pos
;
2045 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
2046 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
2047 + pos
- dtp
->u
.p
.max_pos
;
2048 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
2049 ? 0 : dtp
->u
.p
.pending_spaces
;
2053 consume_data_flag
= 0;
2054 dtp
->u
.p
.sign_status
= SIGN_S
;
2058 consume_data_flag
= 0;
2059 dtp
->u
.p
.sign_status
= SIGN_SS
;
2063 consume_data_flag
= 0;
2064 dtp
->u
.p
.sign_status
= SIGN_SP
;
2068 consume_data_flag
= 0 ;
2069 dtp
->u
.p
.blank_status
= BLANK_NULL
;
2073 consume_data_flag
= 0;
2074 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
2078 consume_data_flag
= 0;
2079 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
2083 consume_data_flag
= 0;
2084 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
2088 consume_data_flag
= 0;
2089 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
2093 consume_data_flag
= 0;
2094 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
2098 consume_data_flag
= 0;
2099 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
2103 consume_data_flag
= 0;
2104 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
2108 consume_data_flag
= 0;
2109 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
2113 consume_data_flag
= 0;
2114 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
2118 consume_data_flag
= 0;
2119 dtp
->u
.p
.scale_factor
= f
->u
.k
;
2123 consume_data_flag
= 0;
2124 dtp
->u
.p
.seen_dollar
= 1;
2128 consume_data_flag
= 0;
2129 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2130 next_record (dtp
, 0);
2134 /* A colon descriptor causes us to exit this loop (in
2135 particular preventing another / descriptor from being
2136 processed) unless there is another data item to be
2138 consume_data_flag
= 0;
2144 internal_error (&dtp
->common
, "Bad format node");
2147 /* Adjust the item count and data pointer. */
2149 if ((consume_data_flag
> 0) && (n
> 0))
2152 p
= ((char *) p
) + size
;
2155 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
2156 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
2161 /* Come here when we need a data descriptor but don't have one. We
2162 push the current format node back onto the input, then return and
2163 let the user program call us back with the data. */
2165 unget_format (dtp
, f
);
2168 /* This function is first called from data_init_transfer to initiate the loop
2169 over each item in the format, transferring data as required. Subsequent
2170 calls to this function occur for each data item foound in the READ/WRITE
2171 statement. The item_count is incremented for each call. Since the first
2172 call is from data_transfer_init, the item_count is always one greater than
2173 the actual count number of the item being transferred. */
2176 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2177 size_t size
, size_t nelems
)
2183 size_t stride
= type
== BT_CHARACTER
?
2184 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2185 if (dtp
->u
.p
.mode
== READING
)
2187 /* Big loop over all the elements. */
2188 for (elem
= 0; elem
< nelems
; elem
++)
2190 dtp
->u
.p
.item_count
++;
2191 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2196 /* Big loop over all the elements. */
2197 for (elem
= 0; elem
< nelems
; elem
++)
2199 dtp
->u
.p
.item_count
++;
2200 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2206 /* Data transfer entry points. The type of the data entity is
2207 implicit in the subroutine call. This prevents us from having to
2208 share a common enum with the compiler. */
2211 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
2213 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2215 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
2219 transfer_integer_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2221 transfer_integer (dtp
, p
, kind
);
2225 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
2228 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2230 size
= size_from_real_kind (kind
);
2231 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
2235 transfer_real_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2237 transfer_real (dtp
, p
, kind
);
2241 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
2243 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2245 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
2249 transfer_logical_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2251 transfer_logical (dtp
, p
, kind
);
2255 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
2257 static char *empty_string
[0];
2259 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2262 /* Strings of zero length can have p == NULL, which confuses the
2263 transfer routines into thinking we need more data elements. To avoid
2264 this, we give them a nice pointer. */
2265 if (len
== 0 && p
== NULL
)
2268 /* Set kind here to 1. */
2269 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
2273 transfer_character_write (st_parameter_dt
*dtp
, void *p
, int len
)
2275 transfer_character (dtp
, p
, len
);
2279 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2281 static char *empty_string
[0];
2283 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2286 /* Strings of zero length can have p == NULL, which confuses the
2287 transfer routines into thinking we need more data elements. To avoid
2288 this, we give them a nice pointer. */
2289 if (len
== 0 && p
== NULL
)
2292 /* Here we pass the actual kind value. */
2293 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
2297 transfer_character_wide_write (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2299 transfer_character_wide (dtp
, p
, len
, kind
);
2303 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
2306 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2308 size
= size_from_complex_kind (kind
);
2309 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
2313 transfer_complex_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2315 transfer_complex (dtp
, p
, kind
);
2319 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2320 gfc_charlen_type charlen
)
2322 index_type count
[GFC_MAX_DIMENSIONS
];
2323 index_type extent
[GFC_MAX_DIMENSIONS
];
2324 index_type stride
[GFC_MAX_DIMENSIONS
];
2325 index_type stride0
, rank
, size
, n
;
2330 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2333 iotype
= (bt
) GFC_DESCRIPTOR_TYPE (desc
);
2334 size
= iotype
== BT_CHARACTER
? charlen
: GFC_DESCRIPTOR_SIZE (desc
);
2336 rank
= GFC_DESCRIPTOR_RANK (desc
);
2337 for (n
= 0; n
< rank
; n
++)
2340 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
2341 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
2343 /* If the extent of even one dimension is zero, then the entire
2344 array section contains zero elements, so we return after writing
2345 a zero array record. */
2350 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2355 stride0
= stride
[0];
2357 /* If the innermost dimension has a stride of 1, we can do the transfer
2358 in contiguous chunks. */
2359 if (stride0
== size
)
2364 data
= GFC_DESCRIPTOR_DATA (desc
);
2368 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2369 data
+= stride0
* tsize
;
2372 while (count
[n
] == extent
[n
])
2375 data
-= stride
[n
] * extent
[n
];
2392 transfer_array_write (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2393 gfc_charlen_type charlen
)
2395 transfer_array (dtp
, desc
, kind
, charlen
);
2399 /* User defined input/output iomsg. */
2401 #define IOMSG_LEN 256
2404 transfer_derived (st_parameter_dt
*parent
, void *dtio_source
, void *dtio_proc
)
2406 if (parent
->u
.p
.current_unit
)
2408 if (parent
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2409 parent
->u
.p
.ufdtio_ptr
= (unformatted_dtio
) dtio_proc
;
2411 parent
->u
.p
.fdtio_ptr
= (formatted_dtio
) dtio_proc
;
2413 parent
->u
.p
.transfer (parent
, BT_CLASS
, dtio_source
, 0, 0, 1);
2417 /* Preposition a sequential unformatted file while reading. */
2420 us_read (st_parameter_dt
*dtp
, int continued
)
2427 if (compile_options
.record_marker
== 0)
2428 n
= sizeof (GFC_INTEGER_4
);
2430 n
= compile_options
.record_marker
;
2432 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
2433 if (unlikely (nr
< 0))
2435 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2441 return; /* end of file */
2443 else if (unlikely (n
!= nr
))
2445 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2449 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2450 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2454 case sizeof(GFC_INTEGER_4
):
2455 memcpy (&i4
, &i
, sizeof (i4
));
2459 case sizeof(GFC_INTEGER_8
):
2460 memcpy (&i8
, &i
, sizeof (i8
));
2465 runtime_error ("Illegal value for record marker");
2475 case sizeof(GFC_INTEGER_4
):
2476 memcpy (&u32
, &i
, sizeof (u32
));
2477 u32
= __builtin_bswap32 (u32
);
2478 memcpy (&i4
, &u32
, sizeof (i4
));
2482 case sizeof(GFC_INTEGER_8
):
2483 memcpy (&u64
, &i
, sizeof (u64
));
2484 u64
= __builtin_bswap64 (u64
);
2485 memcpy (&i8
, &u64
, sizeof (i8
));
2490 runtime_error ("Illegal value for record marker");
2497 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
2498 dtp
->u
.p
.current_unit
->continued
= 0;
2502 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
2503 dtp
->u
.p
.current_unit
->continued
= 1;
2507 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2511 /* Preposition a sequential unformatted file while writing. This
2512 amount to writing a bogus length that will be filled in later. */
2515 us_write (st_parameter_dt
*dtp
, int continued
)
2522 if (compile_options
.record_marker
== 0)
2523 nbytes
= sizeof (GFC_INTEGER_4
);
2525 nbytes
= compile_options
.record_marker
;
2527 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2528 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2530 /* For sequential unformatted, if RECL= was not specified in the OPEN
2531 we write until we have more bytes than can fit in the subrecord
2532 markers, then we write a new subrecord. */
2534 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2535 dtp
->u
.p
.current_unit
->recl_subrecord
;
2536 dtp
->u
.p
.current_unit
->continued
= continued
;
2540 /* Position to the next record prior to transfer. We are assumed to
2541 be before the next record. We also calculate the bytes in the next
2545 pre_position (st_parameter_dt
*dtp
)
2547 if (dtp
->u
.p
.current_unit
->current_record
)
2548 return; /* Already positioned. */
2550 switch (current_mode (dtp
))
2552 case FORMATTED_STREAM
:
2553 case UNFORMATTED_STREAM
:
2554 /* There are no records with stream I/O. If the position was specified
2555 data_transfer_init has already positioned the file. If no position
2556 was specified, we continue from where we last left off. I.e.
2557 there is nothing to do here. */
2560 case UNFORMATTED_SEQUENTIAL
:
2561 if (dtp
->u
.p
.mode
== READING
)
2568 case FORMATTED_SEQUENTIAL
:
2569 case FORMATTED_DIRECT
:
2570 case UNFORMATTED_DIRECT
:
2571 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2575 dtp
->u
.p
.current_unit
->current_record
= 1;
2579 /* Initialize things for a data transfer. This code is common for
2580 both reading and writing. */
2583 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2585 unit_flags u_flags
; /* Used for creating a unit if needed. */
2586 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2587 namelist_info
*ionml
;
2589 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2591 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2593 dtp
->u
.p
.ionml
= ionml
;
2594 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2596 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2599 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2600 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
2602 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2604 if (dtp
->u
.p
.current_unit
->s
== NULL
)
2605 { /* Open the unit with some default flags. */
2606 st_parameter_open opp
;
2609 if (dtp
->common
.unit
< 0)
2611 close_unit (dtp
->u
.p
.current_unit
);
2612 dtp
->u
.p
.current_unit
= NULL
;
2613 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2614 "Bad unit number in statement");
2617 memset (&u_flags
, '\0', sizeof (u_flags
));
2618 u_flags
.access
= ACCESS_SEQUENTIAL
;
2619 u_flags
.action
= ACTION_READWRITE
;
2621 /* Is it unformatted? */
2622 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2623 | IOPARM_DT_IONML_SET
)))
2624 u_flags
.form
= FORM_UNFORMATTED
;
2626 u_flags
.form
= FORM_UNSPECIFIED
;
2628 u_flags
.delim
= DELIM_UNSPECIFIED
;
2629 u_flags
.blank
= BLANK_UNSPECIFIED
;
2630 u_flags
.pad
= PAD_UNSPECIFIED
;
2631 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2632 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2633 u_flags
.async
= ASYNC_UNSPECIFIED
;
2634 u_flags
.round
= ROUND_UNSPECIFIED
;
2635 u_flags
.sign
= SIGN_UNSPECIFIED
;
2637 u_flags
.status
= STATUS_UNKNOWN
;
2639 conv
= get_unformatted_convert (dtp
->common
.unit
);
2641 if (conv
== GFC_CONVERT_NONE
)
2642 conv
= compile_options
.convert
;
2644 /* We use big_endian, which is 0 on little-endian machines
2645 and 1 on big-endian machines. */
2648 case GFC_CONVERT_NATIVE
:
2649 case GFC_CONVERT_SWAP
:
2652 case GFC_CONVERT_BIG
:
2653 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2656 case GFC_CONVERT_LITTLE
:
2657 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2661 internal_error (&opp
.common
, "Illegal value for CONVERT");
2665 u_flags
.convert
= conv
;
2667 opp
.common
= dtp
->common
;
2668 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2669 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2670 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2671 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2672 if (dtp
->u
.p
.current_unit
== NULL
)
2676 /* Check the action. */
2678 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2680 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2681 "Cannot read from file opened for WRITE");
2685 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2687 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2688 "Cannot write to file opened for READ");
2692 dtp
->u
.p
.first_item
= 1;
2694 /* Check the format. */
2696 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2699 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2700 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2703 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2704 "Format present for UNFORMATTED data transfer");
2708 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2710 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2712 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2713 "A format cannot be specified with a namelist");
2717 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2718 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2720 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2721 "Missing format for FORMATTED data transfer");
2725 if (is_internal_unit (dtp
)
2726 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2728 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2729 "Internal file cannot be accessed by UNFORMATTED "
2734 /* Check the record or position number. */
2736 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2737 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2739 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2740 "Direct access data transfer requires record number");
2744 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2746 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2748 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2749 "Record number not allowed for sequential access "
2754 if (compile_options
.warn_std
&&
2755 dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
)
2757 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2758 "Sequential READ or WRITE not allowed after "
2759 "EOF marker, possibly use REWIND or BACKSPACE");
2763 /* Process the ADVANCE option. */
2765 dtp
->u
.p
.advance_status
2766 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2767 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2768 "Bad ADVANCE parameter in data transfer statement");
2770 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2772 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2774 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2775 "ADVANCE specification conflicts with sequential "
2780 if (is_internal_unit (dtp
))
2782 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2783 "ADVANCE specification conflicts with internal file");
2787 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2788 != IOPARM_DT_HAS_FORMAT
)
2790 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2791 "ADVANCE specification requires an explicit format");
2798 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2800 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2802 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2803 "EOR specification requires an ADVANCE specification "
2808 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2809 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2811 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2812 "SIZE specification requires an ADVANCE "
2813 "specification of NO");
2818 { /* Write constraints. */
2819 if ((cf
& IOPARM_END
) != 0)
2821 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2822 "END specification cannot appear in a write "
2827 if ((cf
& IOPARM_EOR
) != 0)
2829 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2830 "EOR specification cannot appear in a write "
2835 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2837 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2838 "SIZE specification cannot appear in a write "
2844 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2845 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2847 /* Check the decimal mode. */
2848 dtp
->u
.p
.current_unit
->decimal_status
2849 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2850 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2851 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2854 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2855 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2857 /* Check the round mode. */
2858 dtp
->u
.p
.current_unit
->round_status
2859 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
2860 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
2861 round_opt
, "Bad ROUND parameter in data transfer "
2864 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
2865 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
2867 /* Check the sign mode. */
2868 dtp
->u
.p
.sign_status
2869 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2870 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2871 "Bad SIGN parameter in data transfer statement");
2873 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2874 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2876 /* Check the blank mode. */
2877 dtp
->u
.p
.blank_status
2878 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2879 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2881 "Bad BLANK parameter in data transfer statement");
2883 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2884 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2886 /* Check the delim mode. */
2887 dtp
->u
.p
.current_unit
->delim_status
2888 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2889 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2890 delim_opt
, "Bad DELIM parameter in data transfer statement");
2892 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2894 if (ionml
&& dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_UNSPECIFIED
)
2895 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
2897 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2900 /* Check the pad mode. */
2901 dtp
->u
.p
.current_unit
->pad_status
2902 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2903 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2904 "Bad PAD parameter in data transfer statement");
2906 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2907 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2909 /* Check to see if we might be reading what we wrote before */
2911 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2912 && !is_internal_unit (dtp
))
2914 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2916 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2917 sflush(dtp
->u
.p
.current_unit
->s
);
2920 /* Check the POS= specifier: that it is in range and that it is used with a
2921 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2923 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2925 if (is_stream_io (dtp
))
2930 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2931 "POS=specifier must be positive");
2935 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2937 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2938 "POS=specifier too large");
2942 dtp
->rec
= dtp
->pos
;
2944 if (dtp
->u
.p
.mode
== READING
)
2946 /* Reset the endfile flag; if we hit EOF during reading
2947 we'll set the flag and generate an error at that point
2948 rather than worrying about it here. */
2949 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2952 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2954 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2955 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
2957 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2960 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2965 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2966 "POS=specifier not allowed, "
2967 "Try OPEN with ACCESS='stream'");
2973 /* Sanity checks on the record number. */
2974 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2978 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2979 "Record number must be positive");
2983 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2985 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2986 "Record number too large");
2990 /* Make sure format buffer is reset. */
2991 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2992 fbuf_reset (dtp
->u
.p
.current_unit
);
2995 /* Check whether the record exists to be read. Only
2996 a partial record needs to exist. */
2998 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2999 * dtp
->u
.p
.current_unit
->recl
>= ssize (dtp
->u
.p
.current_unit
->s
))
3001 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3002 "Non-existing record number");
3006 /* Position the file. */
3007 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
3008 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
3010 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3014 /* TODO: This is required to maintain compatibility between
3015 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
3017 if (is_stream_io (dtp
))
3018 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
3020 /* TODO: Un-comment this code when ABI changes from 4.3.
3021 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
3023 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
3024 "Record number not allowed for stream access "
3030 /* Bugware for badly written mixed C-Fortran I/O. */
3031 if (!is_internal_unit (dtp
))
3032 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
3034 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
3036 /* Set the maximum position reached from the previous I/O operation. This
3037 could be greater than zero from a previous non-advancing write. */
3038 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
3043 /* Set up the subroutine that will handle the transfers. */
3047 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3048 dtp
->u
.p
.transfer
= unformatted_read
;
3051 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3053 if (dtp
->u
.p
.current_unit
->child_dtio
== 0)
3054 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
3055 dtp
->u
.p
.transfer
= list_formatted_read
;
3058 dtp
->u
.p
.transfer
= formatted_transfer
;
3063 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3064 dtp
->u
.p
.transfer
= unformatted_write
;
3067 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3068 dtp
->u
.p
.transfer
= list_formatted_write
;
3070 dtp
->u
.p
.transfer
= formatted_transfer
;
3074 /* Make sure that we don't do a read after a nonadvancing write. */
3078 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
3080 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3081 "Cannot READ after a nonadvancing WRITE");
3087 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
3088 dtp
->u
.p
.current_unit
->read_bad
= 1;
3091 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3093 #ifdef HAVE_USELOCALE
3094 dtp
->u
.p
.old_locale
= uselocale (c_locale
);
3096 __gthread_mutex_lock (&old_locale_lock
);
3097 if (!old_locale_ctr
++)
3099 old_locale
= setlocale (LC_NUMERIC
, NULL
);
3100 setlocale (LC_NUMERIC
, "C");
3102 __gthread_mutex_unlock (&old_locale_lock
);
3104 /* Start the data transfer if we are doing a formatted transfer. */
3105 if ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0
3106 && dtp
->u
.p
.ionml
== NULL
)
3107 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
3112 /* Initialize an array_loop_spec given the array descriptor. The function
3113 returns the index of the last element of the array, and also returns
3114 starting record, where the first I/O goes to (necessary in case of
3115 negative strides). */
3118 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
3119 gfc_offset
*start_record
)
3121 int rank
= GFC_DESCRIPTOR_RANK(desc
);
3130 for (i
=0; i
<rank
; i
++)
3132 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3133 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3134 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
3135 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
3136 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
3137 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
3139 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
3141 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3142 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3146 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3147 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3148 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3149 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3159 /* Determine the index to the next record in an internal unit array by
3160 by incrementing through the array_loop_spec. */
3163 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
3171 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
3176 if (ls
[i
].idx
> ls
[i
].end
)
3178 ls
[i
].idx
= ls
[i
].start
;
3184 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
3194 /* Skip to the end of the current record, taking care of an optional
3195 record marker of size bytes. If the file is not seekable, we
3196 read chunks of size MAX_READ until we get to the right
3200 skip_record (st_parameter_dt
*dtp
, ssize_t bytes
)
3202 ssize_t rlength
, readb
;
3203 #define MAX_READ 4096
3206 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
3207 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
3210 /* Direct access files do not generate END conditions,
3212 if (sseek (dtp
->u
.p
.current_unit
->s
,
3213 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
3215 /* Seeking failed, fall back to seeking by reading data. */
3216 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
3219 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
3220 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3222 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
3225 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3229 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
3233 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= 0;
3237 /* Advance to the next record reading unformatted files, taking
3238 care of subrecords. If complete_record is nonzero, we loop
3239 until all subrecords are cleared. */
3242 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
3246 bytes
= compile_options
.record_marker
== 0 ?
3247 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
3252 /* Skip over tail */
3254 skip_record (dtp
, bytes
);
3256 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
3265 min_off (gfc_offset a
, gfc_offset b
)
3267 return (a
< b
? a
: b
);
3271 /* Space to the next record for read mode. */
3274 next_record_r (st_parameter_dt
*dtp
, int done
)
3281 switch (current_mode (dtp
))
3283 /* No records in unformatted STREAM I/O. */
3284 case UNFORMATTED_STREAM
:
3287 case UNFORMATTED_SEQUENTIAL
:
3288 next_record_r_unf (dtp
, 1);
3289 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3292 case FORMATTED_DIRECT
:
3293 case UNFORMATTED_DIRECT
:
3294 skip_record (dtp
, dtp
->u
.p
.current_unit
->bytes_left
);
3297 case FORMATTED_STREAM
:
3298 case FORMATTED_SEQUENTIAL
:
3299 /* read_sf has already terminated input because of an '\n', or
3301 if (dtp
->u
.p
.sf_seen_eor
)
3303 dtp
->u
.p
.sf_seen_eor
= 0;
3307 if (is_internal_unit (dtp
))
3309 if (is_array_io (dtp
))
3313 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3315 if (!done
&& finished
)
3318 /* Now seek to this record. */
3319 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3320 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3322 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3325 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3329 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3330 bytes_left
= min_off (bytes_left
,
3331 ssize (dtp
->u
.p
.current_unit
->s
)
3332 - stell (dtp
->u
.p
.current_unit
->s
));
3333 if (sseek (dtp
->u
.p
.current_unit
->s
,
3334 bytes_left
, SEEK_CUR
) < 0)
3336 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3339 dtp
->u
.p
.current_unit
->bytes_left
3340 = dtp
->u
.p
.current_unit
->recl
;
3349 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
3353 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3356 if (is_stream_io (dtp
)
3357 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
3358 || dtp
->u
.p
.current_unit
->bytes_left
3359 == dtp
->u
.p
.current_unit
->recl
)
3365 if (is_stream_io (dtp
))
3366 dtp
->u
.p
.current_unit
->strm_pos
++;
3377 /* Small utility function to write a record marker, taking care of
3378 byte swapping and of choosing the correct size. */
3381 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
3387 if (compile_options
.record_marker
== 0)
3388 len
= sizeof (GFC_INTEGER_4
);
3390 len
= compile_options
.record_marker
;
3392 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
3393 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
3397 case sizeof (GFC_INTEGER_4
):
3399 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
3402 case sizeof (GFC_INTEGER_8
):
3404 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
3408 runtime_error ("Illegal value for record marker");
3418 case sizeof (GFC_INTEGER_4
):
3420 memcpy (&u32
, &buf4
, sizeof (u32
));
3421 u32
= __builtin_bswap32 (u32
);
3422 return swrite (dtp
->u
.p
.current_unit
->s
, &u32
, len
);
3425 case sizeof (GFC_INTEGER_8
):
3427 memcpy (&u64
, &buf8
, sizeof (u64
));
3428 u64
= __builtin_bswap64 (u64
);
3429 return swrite (dtp
->u
.p
.current_unit
->s
, &u64
, len
);
3433 runtime_error ("Illegal value for record marker");
3440 /* Position to the next (sub)record in write mode for
3441 unformatted sequential files. */
3444 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
3446 gfc_offset m
, m_write
, record_marker
;
3448 /* Bytes written. */
3449 m
= dtp
->u
.p
.current_unit
->recl_subrecord
3450 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3452 if (compile_options
.record_marker
== 0)
3453 record_marker
= sizeof (GFC_INTEGER_4
);
3455 record_marker
= compile_options
.record_marker
;
3457 /* Seek to the head and overwrite the bogus length with the real
3460 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- record_marker
,
3469 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3472 /* Seek past the end of the current record. */
3474 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
, SEEK_CUR
) < 0))
3477 /* Write the length tail. If we finish a record containing
3478 subrecords, we write out the negative length. */
3480 if (dtp
->u
.p
.current_unit
->continued
)
3485 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3491 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3497 /* Utility function like memset() but operating on streams. Return
3498 value is same as for POSIX write(). */
3501 sset (stream
* s
, int c
, ssize_t nbyte
)
3503 #define WRITE_CHUNK 256
3504 char p
[WRITE_CHUNK
];
3505 ssize_t bytes_left
, trans
;
3507 if (nbyte
< WRITE_CHUNK
)
3508 memset (p
, c
, nbyte
);
3510 memset (p
, c
, WRITE_CHUNK
);
3513 while (bytes_left
> 0)
3515 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
3516 trans
= swrite (s
, p
, trans
);
3519 bytes_left
-= trans
;
3522 return nbyte
- bytes_left
;
3526 /* Position to the next record in write mode. */
3529 next_record_w (st_parameter_dt
*dtp
, int done
)
3531 gfc_offset m
, record
, max_pos
;
3534 /* Zero counters for X- and T-editing. */
3535 max_pos
= dtp
->u
.p
.max_pos
;
3536 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
3538 switch (current_mode (dtp
))
3540 /* No records in unformatted STREAM I/O. */
3541 case UNFORMATTED_STREAM
:
3544 case FORMATTED_DIRECT
:
3545 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
3548 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3549 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
3550 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
3551 dtp
->u
.p
.current_unit
->bytes_left
)
3552 != dtp
->u
.p
.current_unit
->bytes_left
)
3557 case UNFORMATTED_DIRECT
:
3558 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
3560 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3561 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3566 case UNFORMATTED_SEQUENTIAL
:
3567 next_record_w_unf (dtp
, 0);
3568 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3571 case FORMATTED_STREAM
:
3572 case FORMATTED_SEQUENTIAL
:
3574 if (is_internal_unit (dtp
))
3577 if (is_array_io (dtp
))
3581 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3583 /* If the farthest position reached is greater than current
3584 position, adjust the position and set length to pad out
3585 whats left. Otherwise just pad whats left.
3586 (for character array unit) */
3587 m
= dtp
->u
.p
.current_unit
->recl
3588 - dtp
->u
.p
.current_unit
->bytes_left
;
3591 length
= (int) (max_pos
- m
);
3592 if (sseek (dtp
->u
.p
.current_unit
->s
,
3593 length
, SEEK_CUR
) < 0)
3595 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3598 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3601 p
= write_block (dtp
, length
);
3605 if (unlikely (is_char4_unit (dtp
)))
3607 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3608 memset4 (p4
, ' ', length
);
3611 memset (p
, ' ', length
);
3613 /* Now that the current record has been padded out,
3614 determine where the next record in the array is. */
3615 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3618 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3620 /* Now seek to this record */
3621 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3623 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3625 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3629 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3635 /* If this is the last call to next_record move to the farthest
3636 position reached and set length to pad out the remainder
3637 of the record. (for character scaler unit) */
3640 m
= dtp
->u
.p
.current_unit
->recl
3641 - dtp
->u
.p
.current_unit
->bytes_left
;
3644 length
= (int) (max_pos
- m
);
3645 if (sseek (dtp
->u
.p
.current_unit
->s
,
3646 length
, SEEK_CUR
) < 0)
3648 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3651 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3654 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3658 p
= write_block (dtp
, length
);
3662 if (unlikely (is_char4_unit (dtp
)))
3664 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3665 memset4 (p4
, (gfc_char4_t
) ' ', length
);
3668 memset (p
, ' ', length
);
3679 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3680 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3687 if (is_stream_io (dtp
))
3689 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3690 if (dtp
->u
.p
.current_unit
->strm_pos
3691 < ssize (dtp
->u
.p
.current_unit
->s
))
3692 unit_truncate (dtp
->u
.p
.current_unit
,
3693 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3701 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3706 /* Position to the next record, which means moving to the end of the
3707 current record. This can happen under several different
3708 conditions. If the done flag is not set, we get ready to process
3712 next_record (st_parameter_dt
*dtp
, int done
)
3714 gfc_offset fp
; /* File position. */
3716 dtp
->u
.p
.current_unit
->read_bad
= 0;
3718 if (dtp
->u
.p
.mode
== READING
)
3719 next_record_r (dtp
, done
);
3721 next_record_w (dtp
, done
);
3723 if (!is_stream_io (dtp
))
3725 /* Since we have changed the position, set it to unspecified so
3726 that INQUIRE(POSITION=) knows it needs to look into it. */
3728 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_UNSPECIFIED
;
3730 dtp
->u
.p
.current_unit
->current_record
= 0;
3731 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3733 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3734 /* Calculate next record, rounding up partial records. */
3735 dtp
->u
.p
.current_unit
->last_record
=
3736 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
3737 dtp
->u
.p
.current_unit
->recl
;
3740 dtp
->u
.p
.current_unit
->last_record
++;
3746 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3747 smarkeor (dtp
->u
.p
.current_unit
->s
);
3751 /* Finalize the current data transfer. For a nonadvancing transfer,
3752 this means advancing to the next record. For internal units close the
3753 stream associated with the unit. */
3756 finalize_transfer (st_parameter_dt
*dtp
)
3758 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3760 if ((dtp
->u
.p
.ionml
!= NULL
)
3761 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3763 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3764 namelist_read (dtp
);
3766 namelist_write (dtp
);
3769 if (dtp
->u
.p
.current_unit
&& (dtp
->u
.p
.current_unit
->child_dtio
> 0))
3772 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3773 *dtp
->size
= dtp
->u
.p
.size_used
;
3775 if (dtp
->u
.p
.eor_condition
)
3777 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3781 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3783 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3784 dtp
->u
.p
.current_unit
->current_record
= 0;
3788 dtp
->u
.p
.transfer
= NULL
;
3789 if (dtp
->u
.p
.current_unit
== NULL
)
3792 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3794 finish_list_read (dtp
);
3798 if (dtp
->u
.p
.mode
== WRITING
)
3799 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3800 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3802 if (is_stream_io (dtp
))
3804 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3805 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3806 next_record (dtp
, 1);
3811 dtp
->u
.p
.current_unit
->current_record
= 0;
3813 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3815 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3816 dtp
->u
.p
.seen_dollar
= 0;
3820 /* For non-advancing I/O, save the current maximum position for use in the
3821 next I/O operation if needed. */
3822 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3824 if (dtp
->u
.p
.skips
> 0)
3827 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
3828 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
3829 - dtp
->u
.p
.current_unit
->bytes_left
);
3831 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
3834 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3835 - dtp
->u
.p
.current_unit
->bytes_left
);
3836 dtp
->u
.p
.current_unit
->saved_pos
=
3837 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3838 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3841 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3842 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3843 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3845 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3847 next_record (dtp
, 1);
3850 #ifdef HAVE_USELOCALE
3851 if (dtp
->u
.p
.old_locale
!= (locale_t
) 0)
3853 uselocale (dtp
->u
.p
.old_locale
);
3854 dtp
->u
.p
.old_locale
= (locale_t
) 0;
3857 __gthread_mutex_lock (&old_locale_lock
);
3858 if (!--old_locale_ctr
)
3860 setlocale (LC_NUMERIC
, old_locale
);
3863 __gthread_mutex_unlock (&old_locale_lock
);
3867 /* Transfer function for IOLENGTH. It doesn't actually do any
3868 data transfer, it just updates the length counter. */
3871 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3872 void *dest
__attribute__ ((unused
)),
3873 int kind
__attribute__((unused
)),
3874 size_t size
, size_t nelems
)
3876 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3877 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3881 /* Initialize the IOLENGTH data transfer. This function is in essence
3882 a very much simplified version of data_transfer_init(), because it
3883 doesn't have to deal with units at all. */
3886 iolength_transfer_init (st_parameter_dt
*dtp
)
3888 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3891 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3893 /* Set up the subroutine that will handle the transfers. */
3895 dtp
->u
.p
.transfer
= iolength_transfer
;
3899 /* Library entry point for the IOLENGTH form of the INQUIRE
3900 statement. The IOLENGTH form requires no I/O to be performed, but
3901 it must still be a runtime library call so that we can determine
3902 the iolength for dynamic arrays and such. */
3904 extern void st_iolength (st_parameter_dt
*);
3905 export_proto(st_iolength
);
3908 st_iolength (st_parameter_dt
*dtp
)
3910 library_start (&dtp
->common
);
3911 iolength_transfer_init (dtp
);
3914 extern void st_iolength_done (st_parameter_dt
*);
3915 export_proto(st_iolength_done
);
3918 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3925 /* The READ statement. */
3927 extern void st_read (st_parameter_dt
*);
3928 export_proto(st_read
);
3931 st_read (st_parameter_dt
*dtp
)
3933 library_start (&dtp
->common
);
3935 data_transfer_init (dtp
, 1);
3938 extern void st_read_done (st_parameter_dt
*);
3939 export_proto(st_read_done
);
3942 st_read_done (st_parameter_dt
*dtp
)
3944 finalize_transfer (dtp
);
3946 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3948 free_format_data (dtp
->u
.p
.fmt
);
3954 if (dtp
->u
.p
.current_unit
!= NULL
)
3955 unlock_unit (dtp
->u
.p
.current_unit
);
3957 free_internal_unit (dtp
);
3962 extern void st_write (st_parameter_dt
*);
3963 export_proto(st_write
);
3966 st_write (st_parameter_dt
*dtp
)
3968 library_start (&dtp
->common
);
3969 data_transfer_init (dtp
, 0);
3972 extern void st_write_done (st_parameter_dt
*);
3973 export_proto(st_write_done
);
3976 st_write_done (st_parameter_dt
*dtp
)
3978 finalize_transfer (dtp
);
3980 /* Deal with endfile conditions associated with sequential files. */
3982 if (dtp
->u
.p
.current_unit
!= NULL
3983 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
3984 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
3985 switch (dtp
->u
.p
.current_unit
->endfile
)
3987 case AT_ENDFILE
: /* Remain at the endfile record. */
3991 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3995 /* Get rid of whatever is after this record. */
3996 if (!is_internal_unit (dtp
))
3997 unit_truncate (dtp
->u
.p
.current_unit
,
3998 stell (dtp
->u
.p
.current_unit
->s
),
4000 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4004 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
4006 free_format_data (dtp
->u
.p
.fmt
);
4012 if (dtp
->u
.p
.current_unit
!= NULL
)
4013 unlock_unit (dtp
->u
.p
.current_unit
);
4015 free_internal_unit (dtp
);
4021 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
4023 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
4028 /* Receives the scalar information for namelist objects and stores it
4029 in a linked list of namelist_info types. */
4032 set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4033 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4034 GFC_INTEGER_4 dtype
, void *dtio_sub
, void *vtable
)
4036 namelist_info
*t1
= NULL
;
4038 size_t var_name_len
= strlen (var_name
);
4040 nml
= (namelist_info
*) xmalloc (sizeof (namelist_info
));
4042 nml
->mem_pos
= var_addr
;
4043 nml
->dtio_sub
= dtio_sub
;
4044 nml
->vtable
= vtable
;
4046 nml
->var_name
= (char*) xmalloc (var_name_len
+ 1);
4047 memcpy (nml
->var_name
, var_name
, var_name_len
);
4048 nml
->var_name
[var_name_len
] = '\0';
4050 nml
->len
= (int) len
;
4051 nml
->string_length
= (index_type
) string_length
;
4053 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
4054 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
4055 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
4057 if (nml
->var_rank
> 0)
4059 nml
->dim
= (descriptor_dimension
*)
4060 xmallocarray (nml
->var_rank
, sizeof (descriptor_dimension
));
4061 nml
->ls
= (array_loop_spec
*)
4062 xmallocarray (nml
->var_rank
, sizeof (array_loop_spec
));
4072 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
4074 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
4075 dtp
->u
.p
.ionml
= nml
;
4079 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
4084 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
4085 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
4086 export_proto(st_set_nml_var
);
4089 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4090 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4091 GFC_INTEGER_4 dtype
)
4093 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4098 /* Essentially the same as previous but carrying the dtio procedure
4099 and the vtable as additional arguments. */
4100 extern void st_set_nml_dtio_var (st_parameter_dt
*dtp
, void *, char *,
4101 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
,
4103 export_proto(st_set_nml_dtio_var
);
4107 st_set_nml_dtio_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4108 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4109 GFC_INTEGER_4 dtype
, void *dtio_sub
, void *vtable
)
4111 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4112 dtype
, dtio_sub
, vtable
);
4115 /* Store the dimensional information for the namelist object. */
4116 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
4117 index_type
, index_type
,
4119 export_proto(st_set_nml_var_dim
);
4122 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
4123 index_type stride
, index_type lbound
,
4126 namelist_info
* nml
;
4131 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
4133 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
4137 /* Once upon a time, a poor innocent Fortran program was reading a
4138 file, when suddenly it hit the end-of-file (EOF). Unfortunately
4139 the OS doesn't tell whether we're at the EOF or whether we already
4140 went past it. Luckily our hero, libgfortran, keeps track of this.
4141 Call this function when you detect an EOF condition. See Section
4145 hit_eof (st_parameter_dt
* dtp
)
4147 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
4149 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4150 switch (dtp
->u
.p
.current_unit
->endfile
)
4154 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4155 if (!is_internal_unit (dtp
) && !dtp
->u
.p
.namelist_mode
)
4157 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
4158 dtp
->u
.p
.current_unit
->current_record
= 0;
4161 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4165 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
4166 dtp
->u
.p
.current_unit
->current_record
= 0;
4171 /* Non-sequential files don't have an ENDFILE record, so we
4172 can't be at AFTER_ENDFILE. */
4173 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4174 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4175 dtp
->u
.p
.current_unit
->current_record
= 0;