1 /* Copyright (C) 2002-2017 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. */
38 /* Calling conventions: Data transfer statements are unlike other
39 library calls in that they extend over several calls.
41 The first call is always a call to st_read() or st_write(). These
42 subroutines return no status unless a namelist read or write is
43 being done, in which case there is the usual status. No further
44 calls are necessary in this case.
46 For other sorts of data transfer, there are zero or more data
47 transfer statement that depend on the format of the data transfer
48 statement. For READ (and for backwards compatibily: for WRITE), one has
53 transfer_character_wide
61 transfer_integer_write
62 transfer_logical_write
63 transfer_character_write
64 transfer_character_wide_write
66 transfer_complex_write
67 transfer_real128_write
68 transfer_complex128_write
70 These subroutines do not return status. The *128 functions
71 are in the file transfer128.c.
73 The last call is a call to st_[read|write]_done(). While
74 something can easily go wrong with the initial st_read() or
75 st_write(), an error inhibits any data from actually being
78 extern void transfer_integer (st_parameter_dt
*, void *, int);
79 export_proto(transfer_integer
);
81 extern void transfer_integer_write (st_parameter_dt
*, void *, int);
82 export_proto(transfer_integer_write
);
84 extern void transfer_real (st_parameter_dt
*, void *, int);
85 export_proto(transfer_real
);
87 extern void transfer_real_write (st_parameter_dt
*, void *, int);
88 export_proto(transfer_real_write
);
90 extern void transfer_logical (st_parameter_dt
*, void *, int);
91 export_proto(transfer_logical
);
93 extern void transfer_logical_write (st_parameter_dt
*, void *, int);
94 export_proto(transfer_logical_write
);
96 extern void transfer_character (st_parameter_dt
*, void *, int);
97 export_proto(transfer_character
);
99 extern void transfer_character_write (st_parameter_dt
*, void *, int);
100 export_proto(transfer_character_write
);
102 extern void transfer_character_wide (st_parameter_dt
*, void *, int, int);
103 export_proto(transfer_character_wide
);
105 extern void transfer_character_wide_write (st_parameter_dt
*,
107 export_proto(transfer_character_wide_write
);
109 extern void transfer_complex (st_parameter_dt
*, void *, int);
110 export_proto(transfer_complex
);
112 extern void transfer_complex_write (st_parameter_dt
*, void *, int);
113 export_proto(transfer_complex_write
);
115 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
117 export_proto(transfer_array
);
119 extern void transfer_array_write (st_parameter_dt
*, gfc_array_char
*, int,
121 export_proto(transfer_array_write
);
123 /* User defined derived type input/output. */
125 transfer_derived (st_parameter_dt
*dtp
, void *dtio_source
, void *dtio_proc
);
126 export_proto(transfer_derived
);
129 transfer_derived_write (st_parameter_dt
*dtp
, void *dtio_source
, void *dtio_proc
);
130 export_proto(transfer_derived_write
);
132 static void us_read (st_parameter_dt
*, int);
133 static void us_write (st_parameter_dt
*, int);
134 static void next_record_r_unf (st_parameter_dt
*, int);
135 static void next_record_w_unf (st_parameter_dt
*, int);
137 static const st_option advance_opt
[] = {
138 {"yes", ADVANCE_YES
},
144 static const st_option decimal_opt
[] = {
145 {"point", DECIMAL_POINT
},
146 {"comma", DECIMAL_COMMA
},
150 static const st_option round_opt
[] = {
152 {"down", ROUND_DOWN
},
153 {"zero", ROUND_ZERO
},
154 {"nearest", ROUND_NEAREST
},
155 {"compatible", ROUND_COMPATIBLE
},
156 {"processor_defined", ROUND_PROCDEFINED
},
161 static const st_option sign_opt
[] = {
163 {"suppress", SIGN_SS
},
164 {"processor_defined", SIGN_S
},
168 static const st_option blank_opt
[] = {
169 {"null", BLANK_NULL
},
170 {"zero", BLANK_ZERO
},
174 static const st_option delim_opt
[] = {
175 {"apostrophe", DELIM_APOSTROPHE
},
176 {"quote", DELIM_QUOTE
},
177 {"none", DELIM_NONE
},
181 static const st_option pad_opt
[] = {
188 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
189 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
195 current_mode (st_parameter_dt
*dtp
)
199 m
= FORM_UNSPECIFIED
;
201 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
203 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
204 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
206 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
208 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
209 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
211 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
213 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
214 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
221 /* Mid level data transfer statements. */
223 /* Read sequential file - internal unit */
226 read_sf_internal (st_parameter_dt
*dtp
, int * length
)
228 static char *empty_string
[0];
232 /* Zero size array gives internal unit len of 0. Nothing to read. */
233 if (dtp
->internal_unit_len
== 0
234 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
237 /* If we have seen an eor previously, return a length of 0. The
238 caller is responsible for correctly padding the input field. */
239 if (dtp
->u
.p
.sf_seen_eor
)
242 /* Just return something that isn't a NULL pointer, otherwise the
243 caller thinks an error occurred. */
244 return (char*) empty_string
;
247 /* There are some cases with mixed DTIO where we have read a character
248 and saved it in the last character buffer, so we need to backup. */
249 if (unlikely (dtp
->u
.p
.current_unit
->child_dtio
> 0 &&
250 dtp
->u
.p
.current_unit
->last_char
!= EOF
- 1))
252 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
253 sseek (dtp
->u
.p
.current_unit
->s
, -1, SEEK_CUR
);
257 if (is_char4_unit(dtp
))
260 gfc_char4_t
*p
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
,
262 base
= fbuf_alloc (dtp
->u
.p
.current_unit
, lorig
);
263 for (i
= 0; i
< *length
; i
++, p
++)
264 base
[i
] = *p
> 255 ? '?' : (unsigned char) *p
;
267 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
269 if (unlikely (lorig
> *length
))
275 if (base
&& *base
== 0)
277 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
281 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
283 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
284 dtp
->u
.p
.current_unit
->has_size
)
285 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *length
;
291 /* When reading sequential formatted records we have a problem. We
292 don't know how long the line is until we read the trailing newline,
293 and we don't want to read too much. If we read too much, we might
294 have to do a physical seek backwards depending on how much data is
295 present, and devices like terminals aren't seekable and would cause
298 Given this, the solution is to read a byte at a time, stopping if
299 we hit the newline. For small allocations, we use a static buffer.
300 For larger allocations, we are forced to allocate memory on the
301 heap. Hopefully this won't happen very often. */
303 /* Read sequential file - external unit */
306 read_sf (st_parameter_dt
*dtp
, int * length
)
308 static char *empty_string
[0];
310 int n
, lorig
, seen_comma
;
312 /* If we have seen an eor previously, return a length of 0. The
313 caller is responsible for correctly padding the input field. */
314 if (dtp
->u
.p
.sf_seen_eor
)
317 /* Just return something that isn't a NULL pointer, otherwise the
318 caller thinks an error occurred. */
319 return (char*) empty_string
;
322 /* There are some cases with mixed DTIO where we have read a character
323 and saved it in the last character buffer, so we need to backup. */
324 if (unlikely (dtp
->u
.p
.current_unit
->child_dtio
> 0 &&
325 dtp
->u
.p
.current_unit
->last_char
!= EOF
- 1))
327 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
328 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
333 /* Read data into format buffer and scan through it. */
338 q
= fbuf_getc (dtp
->u
.p
.current_unit
);
341 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
342 && (q
== '\n' || q
== '\r'))
344 /* Unexpected end of line. Set the position. */
345 dtp
->u
.p
.sf_seen_eor
= 1;
347 /* If we see an EOR during non-advancing I/O, we need to skip
348 the rest of the I/O statement. Set the corresponding flag. */
349 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
350 dtp
->u
.p
.eor_condition
= 1;
352 /* If we encounter a CR, it might be a CRLF. */
353 if (q
== '\r') /* Probably a CRLF */
355 /* See if there is an LF. */
356 q2
= fbuf_getc (dtp
->u
.p
.current_unit
);
358 dtp
->u
.p
.sf_seen_eor
= 2;
359 else if (q2
!= EOF
) /* Oops, seek back. */
360 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
363 /* Without padding, terminate the I/O statement without assigning
364 the value. With padding, the value still needs to be assigned,
365 so we can just continue with a short read. */
366 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
368 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
375 /* Short circuit the read if a comma is found during numeric input.
376 The flag is set to zero during character reads so that commas in
377 strings are not ignored */
379 if (dtp
->u
.p
.sf_read_comma
== 1)
382 notify_std (&dtp
->common
, GFC_STD_GNU
,
383 "Comma in formatted numeric read.");
391 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
392 some other stuff. Set the relevant flags. */
393 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
397 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
399 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
405 dtp
->u
.p
.eor_condition
= 1;
410 else if (dtp
->u
.p
.advance_status
== ADVANCE_NO
411 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
412 || dtp
->u
.p
.current_unit
->bytes_left
413 == dtp
->u
.p
.current_unit
->recl
)
422 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
424 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
425 dtp
->u
.p
.current_unit
->has_size
)
426 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) n
;
428 /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
429 fbuf_getc might reallocate the buffer. So return current pointer
430 minus all the advances, which is n plus up to two characters
431 of newline or comma. */
432 return fbuf_getptr (dtp
->u
.p
.current_unit
)
433 - n
- dtp
->u
.p
.sf_seen_eor
- seen_comma
;
437 /* Function for reading the next couple of bytes from the current
438 file, advancing the current position. We return NULL on end of record or
439 end of file. This function is only for formatted I/O, unformatted uses
442 If the read is short, then it is because the current record does not
443 have enough data to satisfy the read request and the file was
444 opened with PAD=YES. The caller must assume tailing spaces for
448 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
453 if (!is_stream_io (dtp
))
455 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
457 /* For preconnected units with default record length, set bytes left
458 to unit record length and proceed, otherwise error. */
459 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
460 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
461 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
464 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
465 && !is_internal_unit (dtp
))
467 /* Not enough data left. */
468 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
473 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0
474 && !is_internal_unit(dtp
)))
480 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
484 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
485 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
486 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
488 if (is_internal_unit (dtp
))
489 source
= read_sf_internal (dtp
, nbytes
);
491 source
= read_sf (dtp
, nbytes
);
493 dtp
->u
.p
.current_unit
->strm_pos
+=
494 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
498 /* If we reach here, we can assume it's direct access. */
500 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
503 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
504 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
506 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
507 dtp
->u
.p
.current_unit
->has_size
)
508 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *nbytes
;
510 if (norig
!= *nbytes
)
512 /* Short read, this shouldn't happen. */
513 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
515 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
520 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
526 /* Read a block from a character(kind=4) internal unit, to be transferred into
527 a character(kind=4) variable. Note: Portions of this code borrowed from
530 read_block_form4 (st_parameter_dt
*dtp
, int * nbytes
)
532 static gfc_char4_t
*empty_string
[0];
536 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
537 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
539 /* Zero size array gives internal unit len of 0. Nothing to read. */
540 if (dtp
->internal_unit_len
== 0
541 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
544 /* If we have seen an eor previously, return a length of 0. The
545 caller is responsible for correctly padding the input field. */
546 if (dtp
->u
.p
.sf_seen_eor
)
549 /* Just return something that isn't a NULL pointer, otherwise the
550 caller thinks an error occurred. */
555 source
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
, nbytes
);
557 if (unlikely (lorig
> *nbytes
))
563 dtp
->u
.p
.current_unit
->bytes_left
-= *nbytes
;
565 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
566 dtp
->u
.p
.current_unit
->has_size
)
567 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *nbytes
;
573 /* Reads a block directly into application data space. This is for
574 unformatted files. */
577 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
579 ssize_t to_read_record
;
580 ssize_t have_read_record
;
581 ssize_t to_read_subrecord
;
582 ssize_t have_read_subrecord
;
585 if (is_stream_io (dtp
))
587 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
589 if (unlikely (have_read_record
< 0))
591 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
595 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
597 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
599 /* Short read, e.g. if we hit EOF. For stream files,
600 we have to set the end-of-file condition. */
606 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
608 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
611 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
612 nbytes
= to_read_record
;
617 to_read_record
= nbytes
;
620 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
622 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
623 if (unlikely (to_read_record
< 0))
625 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
629 if (to_read_record
!= (ssize_t
) nbytes
)
631 /* Short read, e.g. if we hit EOF. Apparently, we read
632 more than was written to the last record. */
636 if (unlikely (short_record
))
638 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
643 /* Unformatted sequential. We loop over the subrecords, reading
644 until the request has been fulfilled or the record has run out
645 of continuation subrecords. */
647 /* Check whether we exceed the total record length. */
649 if (dtp
->u
.p
.current_unit
->flags
.has_recl
650 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
652 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
657 to_read_record
= nbytes
;
660 have_read_record
= 0;
664 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
665 < (gfc_offset
) to_read_record
)
667 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
668 to_read_record
-= to_read_subrecord
;
672 to_read_subrecord
= to_read_record
;
676 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
678 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
679 buf
+ have_read_record
, to_read_subrecord
);
680 if (unlikely (have_read_subrecord
< 0))
682 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
686 have_read_record
+= have_read_subrecord
;
688 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
690 /* Short read, e.g. if we hit EOF. This means the record
691 structure has been corrupted, or the trailing record
692 marker would still be present. */
694 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
698 if (to_read_record
> 0)
700 if (likely (dtp
->u
.p
.current_unit
->continued
))
702 next_record_r_unf (dtp
, 0);
707 /* Let's make sure the file position is correctly pre-positioned
708 for the next read statement. */
710 dtp
->u
.p
.current_unit
->current_record
= 0;
711 next_record_r_unf (dtp
, 0);
712 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
718 /* Normal exit, the read request has been fulfilled. */
723 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
724 if (unlikely (short_record
))
726 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
733 /* Function for writing a block of bytes to the current file at the
734 current position, advancing the file pointer. We are given a length
735 and return a pointer to a buffer that the caller must (completely)
736 fill in. Returns NULL on error. */
739 write_block (st_parameter_dt
*dtp
, int length
)
743 if (!is_stream_io (dtp
))
745 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
747 /* For preconnected units with default record length, set bytes left
748 to unit record length and proceed, otherwise error. */
749 if (likely ((dtp
->u
.p
.current_unit
->unit_number
750 == options
.stdout_unit
751 || dtp
->u
.p
.current_unit
->unit_number
752 == options
.stderr_unit
)
753 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
754 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
757 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
762 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
765 if (is_internal_unit (dtp
))
767 if (is_char4_unit(dtp
)) /* char4 internel unit. */
770 dest4
= mem_alloc_w4 (dtp
->u
.p
.current_unit
->s
, &length
);
773 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
779 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
783 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
787 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
788 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
792 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
795 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
800 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
801 dtp
->u
.p
.current_unit
->has_size
)
802 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) length
;
804 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
810 /* High level interface to swrite(), taking care of errors. This is only
811 called for unformatted files. There are three cases to consider:
812 Stream I/O, unformatted direct, unformatted sequential. */
815 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
818 ssize_t have_written
;
819 ssize_t to_write_subrecord
;
824 if (is_stream_io (dtp
))
826 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
827 if (unlikely (have_written
< 0))
829 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
833 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
838 /* Unformatted direct access. */
840 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
842 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
844 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
848 if (buf
== NULL
&& nbytes
== 0)
851 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
852 if (unlikely (have_written
< 0))
854 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
858 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
859 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
864 /* Unformatted sequential. */
868 if (dtp
->u
.p
.current_unit
->flags
.has_recl
869 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
871 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
883 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
884 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
886 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
887 (gfc_offset
) to_write_subrecord
;
889 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
890 buf
+ have_written
, to_write_subrecord
);
891 if (unlikely (to_write_subrecord
< 0))
893 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
897 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
898 nbytes
-= to_write_subrecord
;
899 have_written
+= to_write_subrecord
;
904 next_record_w_unf (dtp
, 1);
907 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
908 if (unlikely (short_record
))
910 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
917 /* Reverse memcpy - used for byte swapping. */
920 reverse_memcpy (void *dest
, const void *src
, size_t n
)
926 s
= (char *) src
+ n
- 1;
928 /* Write with ascending order - this is likely faster
929 on modern architectures because of write combining. */
935 /* Utility function for byteswapping an array, using the bswap
936 builtins if possible. dest and src can overlap completely, or then
937 they must point to separate objects; partial overlaps are not
941 bswap_array (void *dest
, const void *src
, size_t size
, size_t nelems
)
951 for (size_t i
= 0; i
< nelems
; i
++)
952 ((uint16_t*)dest
)[i
] = __builtin_bswap16 (((uint16_t*)src
)[i
]);
955 for (size_t i
= 0; i
< nelems
; i
++)
956 ((uint32_t*)dest
)[i
] = __builtin_bswap32 (((uint32_t*)src
)[i
]);
959 for (size_t i
= 0; i
< nelems
; i
++)
960 ((uint64_t*)dest
)[i
] = __builtin_bswap64 (((uint64_t*)src
)[i
]);
965 for (size_t i
= 0; i
< nelems
; i
++)
968 memcpy (&tmp
, ps
, 4);
969 *(uint32_t*)pd
= __builtin_bswap32 (*(uint32_t*)(ps
+ 8));
970 *(uint32_t*)(pd
+ 4) = __builtin_bswap32 (*(uint32_t*)(ps
+ 4));
971 *(uint32_t*)(pd
+ 8) = __builtin_bswap32 (tmp
);
979 for (size_t i
= 0; i
< nelems
; i
++)
982 memcpy (&tmp
, ps
, 8);
983 *(uint64_t*)pd
= __builtin_bswap64 (*(uint64_t*)(ps
+ 8));
984 *(uint64_t*)(pd
+ 8) = __builtin_bswap64 (tmp
);
994 for (size_t i
= 0; i
< nelems
; i
++)
996 reverse_memcpy (pd
, ps
, size
);
1003 /* In-place byte swap. */
1004 for (size_t i
= 0; i
< nelems
; i
++)
1006 char tmp
, *low
= pd
, *high
= pd
+ size
- 1;
1007 for (size_t j
= 0; j
< size
/2; j
++)
1022 /* Master function for unformatted reads. */
1025 unformatted_read (st_parameter_dt
*dtp
, bt type
,
1026 void *dest
, int kind
, size_t size
, size_t nelems
)
1028 if (type
== BT_CLASS
)
1030 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1031 char tmp_iomsg
[IOMSG_LEN
] = "";
1033 gfc_charlen_type child_iomsg_len
;
1035 int *child_iostat
= NULL
;
1037 /* Set iostat, intent(out). */
1039 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1040 dtp
->common
.iostat
: &noiostat
;
1042 /* Set iomsg, intent(inout). */
1043 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1045 child_iomsg
= dtp
->common
.iomsg
;
1046 child_iomsg_len
= dtp
->common
.iomsg_len
;
1050 child_iomsg
= tmp_iomsg
;
1051 child_iomsg_len
= IOMSG_LEN
;
1054 /* Call the user defined unformatted READ procedure. */
1055 dtp
->u
.p
.current_unit
->child_dtio
++;
1056 dtp
->u
.p
.ufdtio_ptr (dest
, &unit
, child_iostat
, child_iomsg
,
1058 dtp
->u
.p
.current_unit
->child_dtio
--;
1062 if (type
== BT_CHARACTER
)
1063 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
1064 read_block_direct (dtp
, dest
, size
* nelems
);
1066 if (unlikely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_SWAP
)
1069 /* Handle wide chracters. */
1070 if (type
== BT_CHARACTER
)
1076 /* Break up complex into its constituent reals. */
1077 else if (type
== BT_COMPLEX
)
1082 bswap_array (dest
, dest
, size
, nelems
);
1087 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
1088 bytes on 64 bit machines. The unused bytes are not initialized and never
1089 used, which can show an error with memory checking analyzers like
1090 valgrind. We us BT_CLASS to denote a User Defined I/O call. */
1093 unformatted_write (st_parameter_dt
*dtp
, bt type
,
1094 void *source
, int kind
, size_t size
, size_t nelems
)
1096 if (type
== BT_CLASS
)
1098 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1099 char tmp_iomsg
[IOMSG_LEN
] = "";
1101 gfc_charlen_type child_iomsg_len
;
1103 int *child_iostat
= NULL
;
1105 /* Set iostat, intent(out). */
1107 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1108 dtp
->common
.iostat
: &noiostat
;
1110 /* Set iomsg, intent(inout). */
1111 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1113 child_iomsg
= dtp
->common
.iomsg
;
1114 child_iomsg_len
= dtp
->common
.iomsg_len
;
1118 child_iomsg
= tmp_iomsg
;
1119 child_iomsg_len
= IOMSG_LEN
;
1122 /* Call the user defined unformatted WRITE procedure. */
1123 dtp
->u
.p
.current_unit
->child_dtio
++;
1124 dtp
->u
.p
.ufdtio_ptr (source
, &unit
, child_iostat
, child_iomsg
,
1126 dtp
->u
.p
.current_unit
->child_dtio
--;
1130 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1133 size_t stride
= type
== BT_CHARACTER
?
1134 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1136 write_buf (dtp
, source
, stride
* nelems
);
1140 #define BSWAP_BUFSZ 512
1141 char buffer
[BSWAP_BUFSZ
];
1147 /* Handle wide chracters. */
1148 if (type
== BT_CHARACTER
&& kind
!= 1)
1154 /* Break up complex into its constituent reals. */
1155 if (type
== BT_COMPLEX
)
1161 /* By now, all complex variables have been split into their
1162 constituent reals. */
1168 if (size
* nrem
> BSWAP_BUFSZ
)
1169 nc
= BSWAP_BUFSZ
/ size
;
1173 bswap_array (buffer
, p
, size
, nc
);
1174 write_buf (dtp
, buffer
, size
* nc
);
1183 /* Return a pointer to the name of a type. */
1208 p
= "CLASS or DERIVED";
1211 internal_error (NULL
, "type_name(): Bad type");
1218 /* Write a constant string to the output.
1219 This is complicated because the string can have doubled delimiters
1220 in it. The length in the format node is the true length. */
1223 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
1225 char c
, delimiter
, *p
, *q
;
1228 length
= f
->u
.string
.length
;
1232 p
= write_block (dtp
, length
);
1239 for (; length
> 0; length
--)
1242 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
1243 q
++; /* Skip the doubled delimiter. */
1248 /* Given actual and expected types in a formatted data transfer, make
1249 sure they agree. If not, an error message is generated. Returns
1250 nonzero if something went wrong. */
1253 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
1256 char buffer
[BUFLEN
];
1258 if (actual
== expected
)
1261 /* Adjust item_count before emitting error message. */
1262 snprintf (buffer
, BUFLEN
,
1263 "Expected %s for item %d in formatted transfer, got %s",
1264 type_name (expected
), dtp
->u
.p
.item_count
- 1, type_name (actual
));
1266 format_error (dtp
, f
, buffer
);
1271 /* Check that the dtio procedure required for formatted IO is present. */
1274 check_dtio_proc (st_parameter_dt
*dtp
, const fnode
*f
)
1276 char buffer
[BUFLEN
];
1278 if (dtp
->u
.p
.fdtio_ptr
!= NULL
)
1281 snprintf (buffer
, BUFLEN
,
1282 "Missing DTIO procedure or intrinsic type passed for item %d "
1283 "in formatted transfer",
1284 dtp
->u
.p
.item_count
- 1);
1286 format_error (dtp
, f
, buffer
);
1292 require_numeric_type (st_parameter_dt
*dtp
, bt actual
, const fnode
*f
)
1295 char buffer
[BUFLEN
];
1297 if (actual
== BT_INTEGER
|| actual
== BT_REAL
|| actual
== BT_COMPLEX
)
1300 /* Adjust item_count before emitting error message. */
1301 snprintf (buffer
, BUFLEN
,
1302 "Expected numeric type for item %d in formatted transfer, got %s",
1303 dtp
->u
.p
.item_count
- 1, type_name (actual
));
1305 format_error (dtp
, f
, buffer
);
1310 get_dt_format (char *p
, gfc_charlen_type
*length
)
1312 char delim
= p
[-1]; /* The delimiter is always the first character back. */
1314 gfc_charlen_type len
= *length
; /* This length already correct, less 'DT'. */
1316 res
= q
= xmalloc (len
+ 2);
1318 /* Set the beginning of the string to 'DT', length adjusted below. */
1322 /* The string may contain doubled quotes so scan and skip as needed. */
1323 for (; len
> 0; len
--)
1327 p
++; /* Skip the doubled delimiter. */
1330 /* Adjust the string length by two now that we are done. */
1337 /* This function is in the main loop for a formatted data transfer
1338 statement. It would be natural to implement this as a coroutine
1339 with the user program, but C makes that awkward. We loop,
1340 processing format elements. When we actually have to transfer
1341 data instead of just setting flags, we return control to the user
1342 program which calls a function that supplies the address and type
1343 of the next element, then comes back here to process it. */
1346 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1349 int pos
, bytes_used
;
1353 int consume_data_flag
;
1355 /* Change a complex data item into a pair of reals. */
1357 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1358 if (type
== BT_COMPLEX
)
1364 /* If there's an EOR condition, we simulate finalizing the transfer
1365 by doing nothing. */
1366 if (dtp
->u
.p
.eor_condition
)
1369 /* Set this flag so that commas in reads cause the read to complete before
1370 the entire field has been read. The next read field will start right after
1371 the comma in the stream. (Set to 0 for character reads). */
1372 dtp
->u
.p
.sf_read_comma
=
1373 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1377 /* If reversion has occurred and there is another real data item,
1378 then we have to move to the next record. */
1379 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1381 dtp
->u
.p
.reversion_flag
= 0;
1382 next_record (dtp
, 0);
1385 consume_data_flag
= 1;
1386 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1389 f
= next_format (dtp
);
1392 /* No data descriptors left. */
1393 if (unlikely (n
> 0))
1394 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1395 "Insufficient data descriptors in format after reversion");
1401 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1402 - dtp
->u
.p
.current_unit
->bytes_left
);
1404 if (is_stream_io(dtp
))
1411 goto need_read_data
;
1412 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1414 read_decimal (dtp
, f
, p
, kind
);
1419 goto need_read_data
;
1420 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1421 && require_numeric_type (dtp
, type
, f
))
1423 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1424 && require_type (dtp
, BT_INTEGER
, type
, f
))
1426 read_radix (dtp
, f
, p
, kind
, 2);
1431 goto need_read_data
;
1432 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1433 && require_numeric_type (dtp
, type
, f
))
1435 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1436 && require_type (dtp
, BT_INTEGER
, type
, f
))
1438 read_radix (dtp
, f
, p
, kind
, 8);
1443 goto need_read_data
;
1444 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1445 && require_numeric_type (dtp
, type
, f
))
1447 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1448 && require_type (dtp
, BT_INTEGER
, type
, f
))
1450 read_radix (dtp
, f
, p
, kind
, 16);
1455 goto need_read_data
;
1457 /* It is possible to have FMT_A with something not BT_CHARACTER such
1458 as when writing out hollerith strings, so check both type
1459 and kind before calling wide character routines. */
1460 if (type
== BT_CHARACTER
&& kind
== 4)
1461 read_a_char4 (dtp
, f
, p
, size
);
1463 read_a (dtp
, f
, p
, size
);
1468 goto need_read_data
;
1469 read_l (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
;
1484 if (check_dtio_proc (dtp
, f
))
1486 if (require_type (dtp
, BT_CLASS
, type
, f
))
1488 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1490 char tmp_iomsg
[IOMSG_LEN
] = "";
1492 gfc_charlen_type child_iomsg_len
;
1494 int *child_iostat
= NULL
;
1496 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1498 /* Build the iotype string. */
1499 if (iotype_len
== 0)
1505 iotype
= get_dt_format (f
->u
.udf
.string
, &iotype_len
);
1507 /* Set iostat, intent(out). */
1509 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1510 dtp
->common
.iostat
: &noiostat
;
1512 /* Set iomsg, intent(inout). */
1513 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1515 child_iomsg
= dtp
->common
.iomsg
;
1516 child_iomsg_len
= dtp
->common
.iomsg_len
;
1520 child_iomsg
= tmp_iomsg
;
1521 child_iomsg_len
= IOMSG_LEN
;
1524 /* Call the user defined formatted READ procedure. */
1525 dtp
->u
.p
.current_unit
->child_dtio
++;
1526 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
1527 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1528 child_iostat
, child_iomsg
,
1529 iotype_len
, child_iomsg_len
);
1530 dtp
->u
.p
.current_unit
->child_dtio
--;
1532 if (f
->u
.udf
.string_len
!= 0)
1534 /* Note: vlist is freed in free_format_data. */
1539 goto need_read_data
;
1540 if (require_type (dtp
, BT_REAL
, type
, f
))
1542 read_f (dtp
, f
, p
, kind
);
1547 goto need_read_data
;
1548 if (require_type (dtp
, BT_REAL
, type
, f
))
1550 read_f (dtp
, f
, p
, kind
);
1555 goto need_read_data
;
1556 if (require_type (dtp
, BT_REAL
, type
, f
))
1558 read_f (dtp
, f
, p
, kind
);
1563 goto need_read_data
;
1564 if (require_type (dtp
, BT_REAL
, type
, f
))
1566 read_f (dtp
, f
, p
, kind
);
1571 goto need_read_data
;
1575 read_decimal (dtp
, f
, p
, kind
);
1578 read_l (dtp
, f
, p
, kind
);
1582 read_a_char4 (dtp
, f
, p
, size
);
1584 read_a (dtp
, f
, p
, size
);
1587 read_f (dtp
, f
, p
, kind
);
1590 internal_error (&dtp
->common
, "formatted_transfer(): Bad type");
1595 consume_data_flag
= 0;
1596 format_error (dtp
, f
, "Constant string in input format");
1599 /* Format codes that don't transfer data. */
1602 consume_data_flag
= 0;
1603 dtp
->u
.p
.skips
+= f
->u
.n
;
1604 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1605 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1606 read_x (dtp
, f
->u
.n
);
1611 consume_data_flag
= 0;
1613 if (f
->format
== FMT_TL
)
1615 /* Handle the special case when no bytes have been used yet.
1616 Cannot go below zero. */
1617 if (bytes_used
== 0)
1619 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1620 dtp
->u
.p
.skips
-= f
->u
.n
;
1621 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1624 pos
= bytes_used
- f
->u
.n
;
1629 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1630 left tab limit. We do not check if the position has gone
1631 beyond the end of record because a subsequent tab could
1632 bring us back again. */
1633 pos
= pos
< 0 ? 0 : pos
;
1635 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1636 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1637 + pos
- dtp
->u
.p
.max_pos
;
1638 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1639 ? 0 : dtp
->u
.p
.pending_spaces
;
1640 if (dtp
->u
.p
.skips
== 0)
1643 /* Adjust everything for end-of-record condition */
1644 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1646 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1647 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1649 if (dtp
->u
.p
.pending_spaces
== 0)
1650 dtp
->u
.p
.sf_seen_eor
= 0;
1652 if (dtp
->u
.p
.skips
< 0)
1654 if (is_internal_unit (dtp
))
1655 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1657 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1658 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1659 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1662 read_x (dtp
, dtp
->u
.p
.skips
);
1666 consume_data_flag
= 0;
1667 dtp
->u
.p
.sign_status
= SIGN_S
;
1671 consume_data_flag
= 0;
1672 dtp
->u
.p
.sign_status
= SIGN_SS
;
1676 consume_data_flag
= 0;
1677 dtp
->u
.p
.sign_status
= SIGN_SP
;
1681 consume_data_flag
= 0 ;
1682 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1686 consume_data_flag
= 0;
1687 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1691 consume_data_flag
= 0;
1692 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1696 consume_data_flag
= 0;
1697 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1701 consume_data_flag
= 0;
1702 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1706 consume_data_flag
= 0;
1707 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1711 consume_data_flag
= 0;
1712 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1716 consume_data_flag
= 0;
1717 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1721 consume_data_flag
= 0;
1722 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1726 consume_data_flag
= 0;
1727 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1731 consume_data_flag
= 0;
1732 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1736 consume_data_flag
= 0;
1737 dtp
->u
.p
.seen_dollar
= 1;
1741 consume_data_flag
= 0;
1742 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1743 next_record (dtp
, 0);
1747 /* A colon descriptor causes us to exit this loop (in
1748 particular preventing another / descriptor from being
1749 processed) unless there is another data item to be
1751 consume_data_flag
= 0;
1757 internal_error (&dtp
->common
, "Bad format node");
1760 /* Adjust the item count and data pointer. */
1762 if ((consume_data_flag
> 0) && (n
> 0))
1765 p
= ((char *) p
) + size
;
1770 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1771 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1776 /* Come here when we need a data descriptor but don't have one. We
1777 push the current format node back onto the input, then return and
1778 let the user program call us back with the data. */
1780 unget_format (dtp
, f
);
1785 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1788 int pos
, bytes_used
;
1792 int consume_data_flag
;
1794 /* Change a complex data item into a pair of reals. */
1796 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1797 if (type
== BT_COMPLEX
)
1803 /* If there's an EOR condition, we simulate finalizing the transfer
1804 by doing nothing. */
1805 if (dtp
->u
.p
.eor_condition
)
1808 /* Set this flag so that commas in reads cause the read to complete before
1809 the entire field has been read. The next read field will start right after
1810 the comma in the stream. (Set to 0 for character reads). */
1811 dtp
->u
.p
.sf_read_comma
=
1812 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1816 /* If reversion has occurred and there is another real data item,
1817 then we have to move to the next record. */
1818 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1820 dtp
->u
.p
.reversion_flag
= 0;
1821 next_record (dtp
, 0);
1824 consume_data_flag
= 1;
1825 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1828 f
= next_format (dtp
);
1831 /* No data descriptors left. */
1832 if (unlikely (n
> 0))
1833 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1834 "Insufficient data descriptors in format after reversion");
1838 /* Now discharge T, TR and X movements to the right. This is delayed
1839 until a data producing format to suppress trailing spaces. */
1842 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1843 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1844 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1845 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1846 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
1848 || t
== FMT_STRING
))
1850 if (dtp
->u
.p
.skips
> 0)
1853 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1854 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1855 - dtp
->u
.p
.current_unit
->bytes_left
);
1857 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1860 if (dtp
->u
.p
.skips
< 0)
1862 if (is_internal_unit (dtp
))
1863 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1865 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1866 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1868 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1871 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1872 - dtp
->u
.p
.current_unit
->bytes_left
);
1874 if (is_stream_io(dtp
))
1882 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1884 write_i (dtp
, f
, p
, kind
);
1890 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1891 && require_numeric_type (dtp
, type
, f
))
1893 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1894 && require_type (dtp
, BT_INTEGER
, type
, f
))
1896 write_b (dtp
, f
, p
, kind
);
1902 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1903 && require_numeric_type (dtp
, type
, f
))
1905 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1906 && require_type (dtp
, BT_INTEGER
, type
, f
))
1908 write_o (dtp
, f
, p
, kind
);
1914 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1915 && require_numeric_type (dtp
, type
, f
))
1917 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1918 && require_type (dtp
, BT_INTEGER
, type
, f
))
1920 write_z (dtp
, f
, p
, kind
);
1927 /* It is possible to have FMT_A with something not BT_CHARACTER such
1928 as when writing out hollerith strings, so check both type
1929 and kind before calling wide character routines. */
1930 if (type
== BT_CHARACTER
&& kind
== 4)
1931 write_a_char4 (dtp
, f
, p
, size
);
1933 write_a (dtp
, f
, p
, size
);
1939 write_l (dtp
, f
, p
, kind
);
1945 if (require_type (dtp
, BT_REAL
, type
, f
))
1947 write_d (dtp
, f
, p
, kind
);
1953 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1955 char tmp_iomsg
[IOMSG_LEN
] = "";
1957 gfc_charlen_type child_iomsg_len
;
1959 int *child_iostat
= NULL
;
1961 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1963 /* Build the iotype string. */
1964 if (iotype_len
== 0)
1970 iotype
= get_dt_format (f
->u
.udf
.string
, &iotype_len
);
1972 /* Set iostat, intent(out). */
1974 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1975 dtp
->common
.iostat
: &noiostat
;
1977 /* Set iomsg, intent(inout). */
1978 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1980 child_iomsg
= dtp
->common
.iomsg
;
1981 child_iomsg_len
= dtp
->common
.iomsg_len
;
1985 child_iomsg
= tmp_iomsg
;
1986 child_iomsg_len
= IOMSG_LEN
;
1989 if (check_dtio_proc (dtp
, f
))
1992 /* Call the user defined formatted WRITE procedure. */
1993 dtp
->u
.p
.current_unit
->child_dtio
++;
1995 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1996 child_iostat
, child_iomsg
,
1997 iotype_len
, child_iomsg_len
);
1998 dtp
->u
.p
.current_unit
->child_dtio
--;
2000 if (f
->u
.udf
.string_len
!= 0)
2002 /* Note: vlist is freed in free_format_data. */
2008 if (require_type (dtp
, BT_REAL
, type
, f
))
2010 write_e (dtp
, f
, p
, kind
);
2016 if (require_type (dtp
, BT_REAL
, type
, f
))
2018 write_en (dtp
, f
, p
, kind
);
2024 if (require_type (dtp
, BT_REAL
, type
, f
))
2026 write_es (dtp
, f
, p
, kind
);
2032 if (require_type (dtp
, BT_REAL
, type
, f
))
2034 write_f (dtp
, f
, p
, kind
);
2043 write_i (dtp
, f
, p
, kind
);
2046 write_l (dtp
, f
, p
, kind
);
2050 write_a_char4 (dtp
, f
, p
, size
);
2052 write_a (dtp
, f
, p
, size
);
2055 if (f
->u
.real
.w
== 0)
2056 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
2058 write_d (dtp
, f
, p
, kind
);
2061 internal_error (&dtp
->common
,
2062 "formatted_transfer(): Bad type");
2067 consume_data_flag
= 0;
2068 write_constant_string (dtp
, f
);
2071 /* Format codes that don't transfer data. */
2074 consume_data_flag
= 0;
2076 dtp
->u
.p
.skips
+= f
->u
.n
;
2077 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
2078 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
2079 /* Writes occur just before the switch on f->format, above, so
2080 that trailing blanks are suppressed, unless we are doing a
2081 non-advancing write in which case we want to output the blanks
2083 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2085 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
2086 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2092 consume_data_flag
= 0;
2094 if (f
->format
== FMT_TL
)
2097 /* Handle the special case when no bytes have been used yet.
2098 Cannot go below zero. */
2099 if (bytes_used
== 0)
2101 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
2102 dtp
->u
.p
.skips
-= f
->u
.n
;
2103 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
2106 pos
= bytes_used
- f
->u
.n
;
2109 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
2111 /* Standard 10.6.1.1: excessive left tabbing is reset to the
2112 left tab limit. We do not check if the position has gone
2113 beyond the end of record because a subsequent tab could
2114 bring us back again. */
2115 pos
= pos
< 0 ? 0 : pos
;
2117 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
2118 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
2119 + pos
- dtp
->u
.p
.max_pos
;
2120 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
2121 ? 0 : dtp
->u
.p
.pending_spaces
;
2125 consume_data_flag
= 0;
2126 dtp
->u
.p
.sign_status
= SIGN_S
;
2130 consume_data_flag
= 0;
2131 dtp
->u
.p
.sign_status
= SIGN_SS
;
2135 consume_data_flag
= 0;
2136 dtp
->u
.p
.sign_status
= SIGN_SP
;
2140 consume_data_flag
= 0 ;
2141 dtp
->u
.p
.blank_status
= BLANK_NULL
;
2145 consume_data_flag
= 0;
2146 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
2150 consume_data_flag
= 0;
2151 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
2155 consume_data_flag
= 0;
2156 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
2160 consume_data_flag
= 0;
2161 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
2165 consume_data_flag
= 0;
2166 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
2170 consume_data_flag
= 0;
2171 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
2175 consume_data_flag
= 0;
2176 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
2180 consume_data_flag
= 0;
2181 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
2185 consume_data_flag
= 0;
2186 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
2190 consume_data_flag
= 0;
2191 dtp
->u
.p
.scale_factor
= f
->u
.k
;
2195 consume_data_flag
= 0;
2196 dtp
->u
.p
.seen_dollar
= 1;
2200 consume_data_flag
= 0;
2201 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2202 next_record (dtp
, 0);
2206 /* A colon descriptor causes us to exit this loop (in
2207 particular preventing another / descriptor from being
2208 processed) unless there is another data item to be
2210 consume_data_flag
= 0;
2216 internal_error (&dtp
->common
, "Bad format node");
2219 /* Adjust the item count and data pointer. */
2221 if ((consume_data_flag
> 0) && (n
> 0))
2224 p
= ((char *) p
) + size
;
2227 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
2228 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
2233 /* Come here when we need a data descriptor but don't have one. We
2234 push the current format node back onto the input, then return and
2235 let the user program call us back with the data. */
2237 unget_format (dtp
, f
);
2240 /* This function is first called from data_init_transfer to initiate the loop
2241 over each item in the format, transferring data as required. Subsequent
2242 calls to this function occur for each data item foound in the READ/WRITE
2243 statement. The item_count is incremented for each call. Since the first
2244 call is from data_transfer_init, the item_count is always one greater than
2245 the actual count number of the item being transferred. */
2248 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2249 size_t size
, size_t nelems
)
2255 size_t stride
= type
== BT_CHARACTER
?
2256 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2257 if (dtp
->u
.p
.mode
== READING
)
2259 /* Big loop over all the elements. */
2260 for (elem
= 0; elem
< nelems
; elem
++)
2262 dtp
->u
.p
.item_count
++;
2263 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2268 /* Big loop over all the elements. */
2269 for (elem
= 0; elem
< nelems
; elem
++)
2271 dtp
->u
.p
.item_count
++;
2272 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2278 /* Data transfer entry points. The type of the data entity is
2279 implicit in the subroutine call. This prevents us from having to
2280 share a common enum with the compiler. */
2283 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
2285 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2287 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
2291 transfer_integer_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2293 transfer_integer (dtp
, p
, kind
);
2297 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
2300 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2302 size
= size_from_real_kind (kind
);
2303 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
2307 transfer_real_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2309 transfer_real (dtp
, p
, kind
);
2313 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
2315 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2317 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
2321 transfer_logical_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2323 transfer_logical (dtp
, p
, kind
);
2327 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
2329 static char *empty_string
[0];
2331 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2334 /* Strings of zero length can have p == NULL, which confuses the
2335 transfer routines into thinking we need more data elements. To avoid
2336 this, we give them a nice pointer. */
2337 if (len
== 0 && p
== NULL
)
2340 /* Set kind here to 1. */
2341 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
2345 transfer_character_write (st_parameter_dt
*dtp
, void *p
, int len
)
2347 transfer_character (dtp
, p
, len
);
2351 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2353 static char *empty_string
[0];
2355 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2358 /* Strings of zero length can have p == NULL, which confuses the
2359 transfer routines into thinking we need more data elements. To avoid
2360 this, we give them a nice pointer. */
2361 if (len
== 0 && p
== NULL
)
2364 /* Here we pass the actual kind value. */
2365 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
2369 transfer_character_wide_write (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2371 transfer_character_wide (dtp
, p
, len
, kind
);
2375 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
2378 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2380 size
= size_from_complex_kind (kind
);
2381 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
2385 transfer_complex_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2387 transfer_complex (dtp
, p
, kind
);
2391 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2392 gfc_charlen_type charlen
)
2394 index_type count
[GFC_MAX_DIMENSIONS
];
2395 index_type extent
[GFC_MAX_DIMENSIONS
];
2396 index_type stride
[GFC_MAX_DIMENSIONS
];
2397 index_type stride0
, rank
, size
, n
;
2402 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2405 iotype
= (bt
) GFC_DESCRIPTOR_TYPE (desc
);
2406 size
= iotype
== BT_CHARACTER
? charlen
: GFC_DESCRIPTOR_SIZE (desc
);
2408 rank
= GFC_DESCRIPTOR_RANK (desc
);
2409 for (n
= 0; n
< rank
; n
++)
2412 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
2413 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
2415 /* If the extent of even one dimension is zero, then the entire
2416 array section contains zero elements, so we return after writing
2417 a zero array record. */
2422 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2427 stride0
= stride
[0];
2429 /* If the innermost dimension has a stride of 1, we can do the transfer
2430 in contiguous chunks. */
2431 if (stride0
== size
)
2436 data
= GFC_DESCRIPTOR_DATA (desc
);
2440 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2441 data
+= stride0
* tsize
;
2444 while (count
[n
] == extent
[n
])
2447 data
-= stride
[n
] * extent
[n
];
2464 transfer_array_write (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2465 gfc_charlen_type charlen
)
2467 transfer_array (dtp
, desc
, kind
, charlen
);
2471 /* User defined input/output iomsg. */
2473 #define IOMSG_LEN 256
2476 transfer_derived (st_parameter_dt
*parent
, void *dtio_source
, void *dtio_proc
)
2478 if (parent
->u
.p
.current_unit
)
2480 if (parent
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2481 parent
->u
.p
.ufdtio_ptr
= (unformatted_dtio
) dtio_proc
;
2483 parent
->u
.p
.fdtio_ptr
= (formatted_dtio
) dtio_proc
;
2485 parent
->u
.p
.transfer (parent
, BT_CLASS
, dtio_source
, 0, 0, 1);
2489 /* Preposition a sequential unformatted file while reading. */
2492 us_read (st_parameter_dt
*dtp
, int continued
)
2499 if (compile_options
.record_marker
== 0)
2500 n
= sizeof (GFC_INTEGER_4
);
2502 n
= compile_options
.record_marker
;
2504 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
2505 if (unlikely (nr
< 0))
2507 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2513 return; /* end of file */
2515 else if (unlikely (n
!= nr
))
2517 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2521 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2522 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2526 case sizeof(GFC_INTEGER_4
):
2527 memcpy (&i4
, &i
, sizeof (i4
));
2531 case sizeof(GFC_INTEGER_8
):
2532 memcpy (&i8
, &i
, sizeof (i8
));
2537 runtime_error ("Illegal value for record marker");
2547 case sizeof(GFC_INTEGER_4
):
2548 memcpy (&u32
, &i
, sizeof (u32
));
2549 u32
= __builtin_bswap32 (u32
);
2550 memcpy (&i4
, &u32
, sizeof (i4
));
2554 case sizeof(GFC_INTEGER_8
):
2555 memcpy (&u64
, &i
, sizeof (u64
));
2556 u64
= __builtin_bswap64 (u64
);
2557 memcpy (&i8
, &u64
, sizeof (i8
));
2562 runtime_error ("Illegal value for record marker");
2569 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
2570 dtp
->u
.p
.current_unit
->continued
= 0;
2574 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
2575 dtp
->u
.p
.current_unit
->continued
= 1;
2579 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2583 /* Preposition a sequential unformatted file while writing. This
2584 amount to writing a bogus length that will be filled in later. */
2587 us_write (st_parameter_dt
*dtp
, int continued
)
2594 if (compile_options
.record_marker
== 0)
2595 nbytes
= sizeof (GFC_INTEGER_4
);
2597 nbytes
= compile_options
.record_marker
;
2599 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2600 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2602 /* For sequential unformatted, if RECL= was not specified in the OPEN
2603 we write until we have more bytes than can fit in the subrecord
2604 markers, then we write a new subrecord. */
2606 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2607 dtp
->u
.p
.current_unit
->recl_subrecord
;
2608 dtp
->u
.p
.current_unit
->continued
= continued
;
2612 /* Position to the next record prior to transfer. We are assumed to
2613 be before the next record. We also calculate the bytes in the next
2617 pre_position (st_parameter_dt
*dtp
)
2619 if (dtp
->u
.p
.current_unit
->current_record
)
2620 return; /* Already positioned. */
2622 switch (current_mode (dtp
))
2624 case FORMATTED_STREAM
:
2625 case UNFORMATTED_STREAM
:
2626 /* There are no records with stream I/O. If the position was specified
2627 data_transfer_init has already positioned the file. If no position
2628 was specified, we continue from where we last left off. I.e.
2629 there is nothing to do here. */
2632 case UNFORMATTED_SEQUENTIAL
:
2633 if (dtp
->u
.p
.mode
== READING
)
2640 case FORMATTED_SEQUENTIAL
:
2641 case FORMATTED_DIRECT
:
2642 case UNFORMATTED_DIRECT
:
2643 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2647 dtp
->u
.p
.current_unit
->current_record
= 1;
2651 /* Initialize things for a data transfer. This code is common for
2652 both reading and writing. */
2655 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2657 unit_flags u_flags
; /* Used for creating a unit if needed. */
2658 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2659 namelist_info
*ionml
;
2661 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2663 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2665 dtp
->u
.p
.ionml
= ionml
;
2666 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2668 dtp
->u
.p
.cc
.len
= 0;
2670 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2673 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2675 if (dtp
->u
.p
.current_unit
== NULL
)
2677 /* This means we tried to access an external unit < 0 without
2678 having opened it first with NEWUNIT=. */
2679 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2680 "Unit number is negative and unit was not already "
2681 "opened with OPEN(NEWUNIT=...)");
2684 else if (dtp
->u
.p
.current_unit
->s
== NULL
)
2685 { /* Open the unit with some default flags. */
2686 st_parameter_open opp
;
2689 memset (&u_flags
, '\0', sizeof (u_flags
));
2690 u_flags
.access
= ACCESS_SEQUENTIAL
;
2691 u_flags
.action
= ACTION_READWRITE
;
2693 /* Is it unformatted? */
2694 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2695 | IOPARM_DT_IONML_SET
)))
2696 u_flags
.form
= FORM_UNFORMATTED
;
2698 u_flags
.form
= FORM_UNSPECIFIED
;
2700 u_flags
.delim
= DELIM_UNSPECIFIED
;
2701 u_flags
.blank
= BLANK_UNSPECIFIED
;
2702 u_flags
.pad
= PAD_UNSPECIFIED
;
2703 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2704 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2705 u_flags
.async
= ASYNC_UNSPECIFIED
;
2706 u_flags
.round
= ROUND_UNSPECIFIED
;
2707 u_flags
.sign
= SIGN_UNSPECIFIED
;
2708 u_flags
.share
= SHARE_UNSPECIFIED
;
2709 u_flags
.cc
= CC_UNSPECIFIED
;
2710 u_flags
.readonly
= 0;
2712 u_flags
.status
= STATUS_UNKNOWN
;
2714 conv
= get_unformatted_convert (dtp
->common
.unit
);
2716 if (conv
== GFC_CONVERT_NONE
)
2717 conv
= compile_options
.convert
;
2719 /* We use big_endian, which is 0 on little-endian machines
2720 and 1 on big-endian machines. */
2723 case GFC_CONVERT_NATIVE
:
2724 case GFC_CONVERT_SWAP
:
2727 case GFC_CONVERT_BIG
:
2728 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2731 case GFC_CONVERT_LITTLE
:
2732 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2736 internal_error (&opp
.common
, "Illegal value for CONVERT");
2740 u_flags
.convert
= conv
;
2742 opp
.common
= dtp
->common
;
2743 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2744 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2745 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2746 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2747 if (dtp
->u
.p
.current_unit
== NULL
)
2751 if (dtp
->u
.p
.current_unit
->child_dtio
== 0)
2753 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2755 dtp
->u
.p
.current_unit
->has_size
= true;
2756 /* Initialize the count. */
2757 dtp
->u
.p
.current_unit
->size_used
= 0;
2760 dtp
->u
.p
.current_unit
->has_size
= false;
2763 /* Check the action. */
2765 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2767 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2768 "Cannot read from file opened for WRITE");
2772 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2774 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2775 "Cannot write to file opened for READ");
2779 dtp
->u
.p
.first_item
= 1;
2781 /* Check the format. */
2783 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2786 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2787 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2790 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2791 "Format present for UNFORMATTED data transfer");
2795 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2797 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2799 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2800 "A format cannot be specified with a namelist");
2804 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2805 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2807 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2808 "Missing format for FORMATTED data transfer");
2812 if (is_internal_unit (dtp
)
2813 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2815 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2816 "Internal file cannot be accessed by UNFORMATTED "
2821 /* Check the record or position number. */
2823 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2824 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2826 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2827 "Direct access data transfer requires record number");
2831 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2833 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2835 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2836 "Record number not allowed for sequential access "
2841 if (compile_options
.warn_std
&&
2842 dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
)
2844 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2845 "Sequential READ or WRITE not allowed after "
2846 "EOF marker, possibly use REWIND or BACKSPACE");
2851 /* Process the ADVANCE option. */
2853 dtp
->u
.p
.advance_status
2854 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2855 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2856 "Bad ADVANCE parameter in data transfer statement");
2858 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2860 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2862 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2863 "ADVANCE specification conflicts with sequential "
2868 if (is_internal_unit (dtp
))
2870 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2871 "ADVANCE specification conflicts with internal file");
2875 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2876 != IOPARM_DT_HAS_FORMAT
)
2878 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2879 "ADVANCE specification requires an explicit format");
2884 /* Child IO is non-advancing and any ADVANCE= specifier is ignored.
2886 if (dtp
->u
.p
.current_unit
->child_dtio
> 0)
2887 dtp
->u
.p
.advance_status
= ADVANCE_NO
;
2891 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2893 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2895 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2896 "EOR specification requires an ADVANCE specification "
2901 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2902 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2904 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2905 "SIZE specification requires an ADVANCE "
2906 "specification of NO");
2911 { /* Write constraints. */
2912 if ((cf
& IOPARM_END
) != 0)
2914 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2915 "END specification cannot appear in a write "
2920 if ((cf
& IOPARM_EOR
) != 0)
2922 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2923 "EOR specification cannot appear in a write "
2928 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2930 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2931 "SIZE specification cannot appear in a write "
2937 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2938 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2940 /* Check the decimal mode. */
2941 dtp
->u
.p
.current_unit
->decimal_status
2942 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2943 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2944 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2947 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2948 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2950 /* Check the round mode. */
2951 dtp
->u
.p
.current_unit
->round_status
2952 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
2953 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
2954 round_opt
, "Bad ROUND parameter in data transfer "
2957 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
2958 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
2960 /* Check the sign mode. */
2961 dtp
->u
.p
.sign_status
2962 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2963 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2964 "Bad SIGN parameter in data transfer statement");
2966 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2967 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2969 /* Check the blank mode. */
2970 dtp
->u
.p
.blank_status
2971 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2972 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2974 "Bad BLANK parameter in data transfer statement");
2976 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2977 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2979 /* Check the delim mode. */
2980 dtp
->u
.p
.current_unit
->delim_status
2981 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2982 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2983 delim_opt
, "Bad DELIM parameter in data transfer statement");
2985 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2987 if (ionml
&& dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_UNSPECIFIED
)
2988 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
2990 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2993 /* Check the pad mode. */
2994 dtp
->u
.p
.current_unit
->pad_status
2995 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2996 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2997 "Bad PAD parameter in data transfer statement");
2999 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
3000 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
3002 /* Check to see if we might be reading what we wrote before */
3004 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
3005 && !is_internal_unit (dtp
))
3007 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
3009 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
3010 sflush(dtp
->u
.p
.current_unit
->s
);
3013 /* Check the POS= specifier: that it is in range and that it is used with a
3014 unit that has been connected for STREAM access. F2003 9.5.1.10. */
3016 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
3018 if (is_stream_io (dtp
))
3023 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3024 "POS=specifier must be positive");
3028 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
3030 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3031 "POS=specifier too large");
3035 dtp
->rec
= dtp
->pos
;
3037 if (dtp
->u
.p
.mode
== READING
)
3039 /* Reset the endfile flag; if we hit EOF during reading
3040 we'll set the flag and generate an error at that point
3041 rather than worrying about it here. */
3042 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
3045 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
3047 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3048 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
3050 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3053 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
3058 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3059 "POS=specifier not allowed, "
3060 "Try OPEN with ACCESS='stream'");
3066 /* Sanity checks on the record number. */
3067 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
3071 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3072 "Record number must be positive");
3076 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
3078 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3079 "Record number too large");
3083 /* Make sure format buffer is reset. */
3084 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3085 fbuf_reset (dtp
->u
.p
.current_unit
);
3088 /* Check whether the record exists to be read. Only
3089 a partial record needs to exist. */
3091 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
3092 * dtp
->u
.p
.current_unit
->recl
>= ssize (dtp
->u
.p
.current_unit
->s
))
3094 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3095 "Non-existing record number");
3099 /* Position the file. */
3100 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
3101 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
3103 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3107 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
3109 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3110 "Record number not allowed for stream access "
3116 /* Bugware for badly written mixed C-Fortran I/O. */
3117 if (!is_internal_unit (dtp
))
3118 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
3120 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
3122 /* Set the maximum position reached from the previous I/O operation. This
3123 could be greater than zero from a previous non-advancing write. */
3124 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
3129 /* Set up the subroutine that will handle the transfers. */
3133 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3134 dtp
->u
.p
.transfer
= unformatted_read
;
3137 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3139 if (dtp
->u
.p
.current_unit
->child_dtio
== 0)
3140 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
3141 dtp
->u
.p
.transfer
= list_formatted_read
;
3144 dtp
->u
.p
.transfer
= formatted_transfer
;
3149 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3150 dtp
->u
.p
.transfer
= unformatted_write
;
3153 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3154 dtp
->u
.p
.transfer
= list_formatted_write
;
3156 dtp
->u
.p
.transfer
= formatted_transfer
;
3160 /* Make sure that we don't do a read after a nonadvancing write. */
3164 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
3166 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3167 "Cannot READ after a nonadvancing WRITE");
3173 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
3174 dtp
->u
.p
.current_unit
->read_bad
= 1;
3177 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3179 #ifdef HAVE_USELOCALE
3180 dtp
->u
.p
.old_locale
= uselocale (c_locale
);
3182 __gthread_mutex_lock (&old_locale_lock
);
3183 if (!old_locale_ctr
++)
3185 old_locale
= setlocale (LC_NUMERIC
, NULL
);
3186 setlocale (LC_NUMERIC
, "C");
3188 __gthread_mutex_unlock (&old_locale_lock
);
3190 /* Start the data transfer if we are doing a formatted transfer. */
3191 if ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0
3192 && dtp
->u
.p
.ionml
== NULL
)
3193 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
3198 /* Initialize an array_loop_spec given the array descriptor. The function
3199 returns the index of the last element of the array, and also returns
3200 starting record, where the first I/O goes to (necessary in case of
3201 negative strides). */
3204 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
3205 gfc_offset
*start_record
)
3207 int rank
= GFC_DESCRIPTOR_RANK(desc
);
3216 for (i
=0; i
<rank
; i
++)
3218 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3219 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3220 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
3221 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
3222 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
3223 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
3225 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
3227 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3228 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3232 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3233 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3234 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3235 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3245 /* Determine the index to the next record in an internal unit array by
3246 by incrementing through the array_loop_spec. */
3249 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
3257 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
3262 if (ls
[i
].idx
> ls
[i
].end
)
3264 ls
[i
].idx
= ls
[i
].start
;
3270 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
3280 /* Skip to the end of the current record, taking care of an optional
3281 record marker of size bytes. If the file is not seekable, we
3282 read chunks of size MAX_READ until we get to the right
3286 skip_record (st_parameter_dt
*dtp
, ssize_t bytes
)
3288 ssize_t rlength
, readb
;
3289 #define MAX_READ 4096
3292 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
3293 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
3296 /* Direct access files do not generate END conditions,
3298 if (sseek (dtp
->u
.p
.current_unit
->s
,
3299 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
3301 /* Seeking failed, fall back to seeking by reading data. */
3302 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
3305 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
3306 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3308 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
3311 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3315 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
3319 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= 0;
3323 /* Advance to the next record reading unformatted files, taking
3324 care of subrecords. If complete_record is nonzero, we loop
3325 until all subrecords are cleared. */
3328 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
3332 bytes
= compile_options
.record_marker
== 0 ?
3333 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
3338 /* Skip over tail */
3340 skip_record (dtp
, bytes
);
3342 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
3351 min_off (gfc_offset a
, gfc_offset b
)
3353 return (a
< b
? a
: b
);
3357 /* Space to the next record for read mode. */
3360 next_record_r (st_parameter_dt
*dtp
, int done
)
3367 switch (current_mode (dtp
))
3369 /* No records in unformatted STREAM I/O. */
3370 case UNFORMATTED_STREAM
:
3373 case UNFORMATTED_SEQUENTIAL
:
3374 next_record_r_unf (dtp
, 1);
3375 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3378 case FORMATTED_DIRECT
:
3379 case UNFORMATTED_DIRECT
:
3380 skip_record (dtp
, dtp
->u
.p
.current_unit
->bytes_left
);
3383 case FORMATTED_STREAM
:
3384 case FORMATTED_SEQUENTIAL
:
3385 /* read_sf has already terminated input because of an '\n', or
3387 if (dtp
->u
.p
.sf_seen_eor
)
3389 dtp
->u
.p
.sf_seen_eor
= 0;
3393 if (is_internal_unit (dtp
))
3395 if (is_array_io (dtp
))
3399 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3401 if (!done
&& finished
)
3404 /* Now seek to this record. */
3405 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3406 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3408 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3411 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3415 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3416 bytes_left
= min_off (bytes_left
,
3417 ssize (dtp
->u
.p
.current_unit
->s
)
3418 - stell (dtp
->u
.p
.current_unit
->s
));
3419 if (sseek (dtp
->u
.p
.current_unit
->s
,
3420 bytes_left
, SEEK_CUR
) < 0)
3422 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3425 dtp
->u
.p
.current_unit
->bytes_left
3426 = dtp
->u
.p
.current_unit
->recl
;
3430 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
3435 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
3439 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3442 if (is_stream_io (dtp
)
3443 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
3444 || dtp
->u
.p
.current_unit
->bytes_left
3445 == dtp
->u
.p
.current_unit
->recl
)
3451 if (is_stream_io (dtp
))
3452 dtp
->u
.p
.current_unit
->strm_pos
++;
3463 /* Small utility function to write a record marker, taking care of
3464 byte swapping and of choosing the correct size. */
3467 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
3473 if (compile_options
.record_marker
== 0)
3474 len
= sizeof (GFC_INTEGER_4
);
3476 len
= compile_options
.record_marker
;
3478 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
3479 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
3483 case sizeof (GFC_INTEGER_4
):
3485 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
3488 case sizeof (GFC_INTEGER_8
):
3490 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
3494 runtime_error ("Illegal value for record marker");
3504 case sizeof (GFC_INTEGER_4
):
3506 memcpy (&u32
, &buf4
, sizeof (u32
));
3507 u32
= __builtin_bswap32 (u32
);
3508 return swrite (dtp
->u
.p
.current_unit
->s
, &u32
, len
);
3511 case sizeof (GFC_INTEGER_8
):
3513 memcpy (&u64
, &buf8
, sizeof (u64
));
3514 u64
= __builtin_bswap64 (u64
);
3515 return swrite (dtp
->u
.p
.current_unit
->s
, &u64
, len
);
3519 runtime_error ("Illegal value for record marker");
3526 /* Position to the next (sub)record in write mode for
3527 unformatted sequential files. */
3530 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
3532 gfc_offset m
, m_write
, record_marker
;
3534 /* Bytes written. */
3535 m
= dtp
->u
.p
.current_unit
->recl_subrecord
3536 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3538 if (compile_options
.record_marker
== 0)
3539 record_marker
= sizeof (GFC_INTEGER_4
);
3541 record_marker
= compile_options
.record_marker
;
3543 /* Seek to the head and overwrite the bogus length with the real
3546 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- record_marker
,
3555 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3558 /* Seek past the end of the current record. */
3560 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
, SEEK_CUR
) < 0))
3563 /* Write the length tail. If we finish a record containing
3564 subrecords, we write out the negative length. */
3566 if (dtp
->u
.p
.current_unit
->continued
)
3571 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3577 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3583 /* Utility function like memset() but operating on streams. Return
3584 value is same as for POSIX write(). */
3587 sset (stream
* s
, int c
, ssize_t nbyte
)
3589 #define WRITE_CHUNK 256
3590 char p
[WRITE_CHUNK
];
3591 ssize_t bytes_left
, trans
;
3593 if (nbyte
< WRITE_CHUNK
)
3594 memset (p
, c
, nbyte
);
3596 memset (p
, c
, WRITE_CHUNK
);
3599 while (bytes_left
> 0)
3601 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
3602 trans
= swrite (s
, p
, trans
);
3605 bytes_left
-= trans
;
3608 return nbyte
- bytes_left
;
3612 /* Finish up a record according to the legacy carriagecontrol type, based
3613 on the first character in the record. */
3616 next_record_cc (st_parameter_dt
*dtp
)
3618 /* Only valid with CARRIAGECONTROL=FORTRAN. */
3619 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
3622 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3623 if (dtp
->u
.p
.cc
.len
> 0)
3625 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, dtp
->u
.p
.cc
.len
);
3627 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3629 /* Output CR for the first character with default CC setting. */
3630 *(p
++) = dtp
->u
.p
.cc
.u
.end
;
3631 if (dtp
->u
.p
.cc
.len
> 1)
3632 *p
= dtp
->u
.p
.cc
.u
.end
;
3636 /* Position to the next record in write mode. */
3639 next_record_w (st_parameter_dt
*dtp
, int done
)
3641 gfc_offset m
, record
, max_pos
;
3644 /* Zero counters for X- and T-editing. */
3645 max_pos
= dtp
->u
.p
.max_pos
;
3646 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
3648 switch (current_mode (dtp
))
3650 /* No records in unformatted STREAM I/O. */
3651 case UNFORMATTED_STREAM
:
3654 case FORMATTED_DIRECT
:
3655 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
3658 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3659 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
3660 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
3661 dtp
->u
.p
.current_unit
->bytes_left
)
3662 != dtp
->u
.p
.current_unit
->bytes_left
)
3667 case UNFORMATTED_DIRECT
:
3668 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
3670 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3671 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3676 case UNFORMATTED_SEQUENTIAL
:
3677 next_record_w_unf (dtp
, 0);
3678 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3681 case FORMATTED_STREAM
:
3682 case FORMATTED_SEQUENTIAL
:
3684 if (is_internal_unit (dtp
))
3687 if (is_array_io (dtp
))
3691 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3693 /* If the farthest position reached is greater than current
3694 position, adjust the position and set length to pad out
3695 whats left. Otherwise just pad whats left.
3696 (for character array unit) */
3697 m
= dtp
->u
.p
.current_unit
->recl
3698 - dtp
->u
.p
.current_unit
->bytes_left
;
3701 length
= (int) (max_pos
- m
);
3702 if (sseek (dtp
->u
.p
.current_unit
->s
,
3703 length
, SEEK_CUR
) < 0)
3705 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3708 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3711 p
= write_block (dtp
, length
);
3715 if (unlikely (is_char4_unit (dtp
)))
3717 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3718 memset4 (p4
, ' ', length
);
3721 memset (p
, ' ', length
);
3723 /* Now that the current record has been padded out,
3724 determine where the next record in the array is. */
3725 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3728 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3730 /* Now seek to this record */
3731 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3733 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3735 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3739 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3745 /* If this is the last call to next_record move to the farthest
3746 position reached and set length to pad out the remainder
3747 of the record. (for character scaler unit) */
3750 m
= dtp
->u
.p
.current_unit
->recl
3751 - dtp
->u
.p
.current_unit
->bytes_left
;
3754 length
= (int) (max_pos
- m
);
3755 if (sseek (dtp
->u
.p
.current_unit
->s
,
3756 length
, SEEK_CUR
) < 0)
3758 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3761 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3764 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3768 p
= write_block (dtp
, length
);
3772 if (unlikely (is_char4_unit (dtp
)))
3774 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3775 memset4 (p4
, (gfc_char4_t
) ' ', length
);
3778 memset (p
, ' ', length
);
3782 /* Handle legacy CARRIAGECONTROL line endings. */
3783 else if (dtp
->u
.p
.current_unit
->flags
.cc
== CC_FORTRAN
)
3784 next_record_cc (dtp
);
3787 /* Skip newlines for CC=CC_NONE. */
3788 const int len
= (dtp
->u
.p
.current_unit
->flags
.cc
== CC_NONE
)
3795 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3796 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
3798 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3806 if (is_stream_io (dtp
))
3808 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3809 if (dtp
->u
.p
.current_unit
->strm_pos
3810 < ssize (dtp
->u
.p
.current_unit
->s
))
3811 unit_truncate (dtp
->u
.p
.current_unit
,
3812 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3820 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3825 /* Position to the next record, which means moving to the end of the
3826 current record. This can happen under several different
3827 conditions. If the done flag is not set, we get ready to process
3831 next_record (st_parameter_dt
*dtp
, int done
)
3833 gfc_offset fp
; /* File position. */
3835 dtp
->u
.p
.current_unit
->read_bad
= 0;
3837 if (dtp
->u
.p
.mode
== READING
)
3838 next_record_r (dtp
, done
);
3840 next_record_w (dtp
, done
);
3842 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3844 if (!is_stream_io (dtp
))
3846 /* Since we have changed the position, set it to unspecified so
3847 that INQUIRE(POSITION=) knows it needs to look into it. */
3849 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_UNSPECIFIED
;
3851 dtp
->u
.p
.current_unit
->current_record
= 0;
3852 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3854 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3855 /* Calculate next record, rounding up partial records. */
3856 dtp
->u
.p
.current_unit
->last_record
=
3857 (fp
+ dtp
->u
.p
.current_unit
->recl
) /
3858 dtp
->u
.p
.current_unit
->recl
- 1;
3861 dtp
->u
.p
.current_unit
->last_record
++;
3867 smarkeor (dtp
->u
.p
.current_unit
->s
);
3871 /* Finalize the current data transfer. For a nonadvancing transfer,
3872 this means advancing to the next record. For internal units close the
3873 stream associated with the unit. */
3876 finalize_transfer (st_parameter_dt
*dtp
)
3878 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3880 if ((dtp
->u
.p
.ionml
!= NULL
)
3881 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3883 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3884 namelist_read (dtp
);
3886 namelist_write (dtp
);
3889 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3890 *dtp
->size
= dtp
->u
.p
.current_unit
->size_used
;
3892 if (dtp
->u
.p
.eor_condition
)
3894 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3898 if (dtp
->u
.p
.current_unit
&& (dtp
->u
.p
.current_unit
->child_dtio
> 0))
3900 if (cf
& IOPARM_DT_HAS_FORMAT
)
3902 free (dtp
->u
.p
.fmt
);
3908 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3910 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3911 dtp
->u
.p
.current_unit
->current_record
= 0;
3915 dtp
->u
.p
.transfer
= NULL
;
3916 if (dtp
->u
.p
.current_unit
== NULL
)
3919 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3921 finish_list_read (dtp
);
3925 if (dtp
->u
.p
.mode
== WRITING
)
3926 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3927 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3929 if (is_stream_io (dtp
))
3931 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3932 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3933 next_record (dtp
, 1);
3938 dtp
->u
.p
.current_unit
->current_record
= 0;
3940 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3942 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3943 dtp
->u
.p
.seen_dollar
= 0;
3947 /* For non-advancing I/O, save the current maximum position for use in the
3948 next I/O operation if needed. */
3949 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3951 if (dtp
->u
.p
.skips
> 0)
3954 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
3955 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
3956 - dtp
->u
.p
.current_unit
->bytes_left
);
3958 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
3961 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3962 - dtp
->u
.p
.current_unit
->bytes_left
);
3963 dtp
->u
.p
.current_unit
->saved_pos
=
3964 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3965 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3968 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3969 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3970 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3972 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3974 next_record (dtp
, 1);
3977 #ifdef HAVE_USELOCALE
3978 if (dtp
->u
.p
.old_locale
!= (locale_t
) 0)
3980 uselocale (dtp
->u
.p
.old_locale
);
3981 dtp
->u
.p
.old_locale
= (locale_t
) 0;
3984 __gthread_mutex_lock (&old_locale_lock
);
3985 if (!--old_locale_ctr
)
3987 setlocale (LC_NUMERIC
, old_locale
);
3990 __gthread_mutex_unlock (&old_locale_lock
);
3994 /* Transfer function for IOLENGTH. It doesn't actually do any
3995 data transfer, it just updates the length counter. */
3998 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3999 void *dest
__attribute__ ((unused
)),
4000 int kind
__attribute__((unused
)),
4001 size_t size
, size_t nelems
)
4003 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
4004 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
4008 /* Initialize the IOLENGTH data transfer. This function is in essence
4009 a very much simplified version of data_transfer_init(), because it
4010 doesn't have to deal with units at all. */
4013 iolength_transfer_init (st_parameter_dt
*dtp
)
4015 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
4018 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
4020 /* Set up the subroutine that will handle the transfers. */
4022 dtp
->u
.p
.transfer
= iolength_transfer
;
4026 /* Library entry point for the IOLENGTH form of the INQUIRE
4027 statement. The IOLENGTH form requires no I/O to be performed, but
4028 it must still be a runtime library call so that we can determine
4029 the iolength for dynamic arrays and such. */
4031 extern void st_iolength (st_parameter_dt
*);
4032 export_proto(st_iolength
);
4035 st_iolength (st_parameter_dt
*dtp
)
4037 library_start (&dtp
->common
);
4038 iolength_transfer_init (dtp
);
4041 extern void st_iolength_done (st_parameter_dt
*);
4042 export_proto(st_iolength_done
);
4045 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
4052 /* The READ statement. */
4054 extern void st_read (st_parameter_dt
*);
4055 export_proto(st_read
);
4058 st_read (st_parameter_dt
*dtp
)
4060 library_start (&dtp
->common
);
4062 data_transfer_init (dtp
, 1);
4065 extern void st_read_done (st_parameter_dt
*);
4066 export_proto(st_read_done
);
4069 st_read_done (st_parameter_dt
*dtp
)
4071 finalize_transfer (dtp
);
4075 /* If this is a parent READ statement we do not need to retain the
4076 internal unit structure for child use. Free it and stash the unit
4077 number for reuse. */
4078 if (dtp
->u
.p
.current_unit
!= NULL
4079 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4081 if (is_internal_unit (dtp
) &&
4082 (dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4084 free (dtp
->u
.p
.current_unit
->filename
);
4085 dtp
->u
.p
.current_unit
->filename
= NULL
;
4086 free (dtp
->u
.p
.current_unit
->s
);
4087 dtp
->u
.p
.current_unit
->s
= NULL
;
4088 if (dtp
->u
.p
.current_unit
->ls
)
4089 free (dtp
->u
.p
.current_unit
->ls
);
4090 dtp
->u
.p
.current_unit
->ls
= NULL
;
4091 stash_internal_unit (dtp
);
4093 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
4095 free_format_data (dtp
->u
.p
.fmt
);
4098 unlock_unit (dtp
->u
.p
.current_unit
);
4104 extern void st_write (st_parameter_dt
*);
4105 export_proto(st_write
);
4108 st_write (st_parameter_dt
*dtp
)
4110 library_start (&dtp
->common
);
4111 data_transfer_init (dtp
, 0);
4114 extern void st_write_done (st_parameter_dt
*);
4115 export_proto(st_write_done
);
4118 st_write_done (st_parameter_dt
*dtp
)
4120 finalize_transfer (dtp
);
4122 if (dtp
->u
.p
.current_unit
!= NULL
4123 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4125 /* Deal with endfile conditions associated with sequential files. */
4126 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4127 switch (dtp
->u
.p
.current_unit
->endfile
)
4129 case AT_ENDFILE
: /* Remain at the endfile record. */
4133 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
4137 /* Get rid of whatever is after this record. */
4138 if (!is_internal_unit (dtp
))
4139 unit_truncate (dtp
->u
.p
.current_unit
,
4140 stell (dtp
->u
.p
.current_unit
->s
),
4142 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4148 /* If this is a parent WRITE statement we do not need to retain the
4149 internal unit structure for child use. Free it and stash the
4150 unit number for reuse. */
4151 if (is_internal_unit (dtp
) &&
4152 (dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4154 free (dtp
->u
.p
.current_unit
->filename
);
4155 dtp
->u
.p
.current_unit
->filename
= NULL
;
4156 free (dtp
->u
.p
.current_unit
->s
);
4157 dtp
->u
.p
.current_unit
->s
= NULL
;
4158 if (dtp
->u
.p
.current_unit
->ls
)
4159 free (dtp
->u
.p
.current_unit
->ls
);
4160 dtp
->u
.p
.current_unit
->ls
= NULL
;
4161 stash_internal_unit (dtp
);
4163 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
4165 free_format_data (dtp
->u
.p
.fmt
);
4168 unlock_unit (dtp
->u
.p
.current_unit
);
4174 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
4176 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
4181 /* Receives the scalar information for namelist objects and stores it
4182 in a linked list of namelist_info types. */
4185 set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4186 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4187 GFC_INTEGER_4 dtype
, void *dtio_sub
, void *vtable
)
4189 namelist_info
*t1
= NULL
;
4191 size_t var_name_len
= strlen (var_name
);
4193 nml
= (namelist_info
*) xmalloc (sizeof (namelist_info
));
4195 nml
->mem_pos
= var_addr
;
4196 nml
->dtio_sub
= dtio_sub
;
4197 nml
->vtable
= vtable
;
4199 nml
->var_name
= (char*) xmalloc (var_name_len
+ 1);
4200 memcpy (nml
->var_name
, var_name
, var_name_len
);
4201 nml
->var_name
[var_name_len
] = '\0';
4203 nml
->len
= (int) len
;
4204 nml
->string_length
= (index_type
) string_length
;
4206 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
4207 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
4208 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
4210 if (nml
->var_rank
> 0)
4212 nml
->dim
= (descriptor_dimension
*)
4213 xmallocarray (nml
->var_rank
, sizeof (descriptor_dimension
));
4214 nml
->ls
= (array_loop_spec
*)
4215 xmallocarray (nml
->var_rank
, sizeof (array_loop_spec
));
4225 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
4227 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
4228 dtp
->u
.p
.ionml
= nml
;
4232 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
4237 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
4238 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
4239 export_proto(st_set_nml_var
);
4242 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4243 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4244 GFC_INTEGER_4 dtype
)
4246 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4251 /* Essentially the same as previous but carrying the dtio procedure
4252 and the vtable as additional arguments. */
4253 extern void st_set_nml_dtio_var (st_parameter_dt
*dtp
, void *, char *,
4254 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
,
4256 export_proto(st_set_nml_dtio_var
);
4260 st_set_nml_dtio_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4261 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4262 GFC_INTEGER_4 dtype
, void *dtio_sub
, void *vtable
)
4264 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4265 dtype
, dtio_sub
, vtable
);
4268 /* Store the dimensional information for the namelist object. */
4269 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
4270 index_type
, index_type
,
4272 export_proto(st_set_nml_var_dim
);
4275 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
4276 index_type stride
, index_type lbound
,
4279 namelist_info
* nml
;
4284 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
4286 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
4290 /* Once upon a time, a poor innocent Fortran program was reading a
4291 file, when suddenly it hit the end-of-file (EOF). Unfortunately
4292 the OS doesn't tell whether we're at the EOF or whether we already
4293 went past it. Luckily our hero, libgfortran, keeps track of this.
4294 Call this function when you detect an EOF condition. See Section
4298 hit_eof (st_parameter_dt
* dtp
)
4300 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
4302 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4303 switch (dtp
->u
.p
.current_unit
->endfile
)
4307 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4308 if (!is_internal_unit (dtp
) && !dtp
->u
.p
.namelist_mode
)
4310 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
4311 dtp
->u
.p
.current_unit
->current_record
= 0;
4314 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4318 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
4319 dtp
->u
.p
.current_unit
->current_record
= 0;
4324 /* Non-sequential files don't have an ENDFILE record, so we
4325 can't be at AFTER_ENDFILE. */
4326 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4327 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4328 dtp
->u
.p
.current_unit
->current_record
= 0;