1 /* Copyright (C) 2002-2018 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. */
39 /* Calling conventions: Data transfer statements are unlike other
40 library calls in that they extend over several calls.
42 The first call is always a call to st_read() or st_write(). These
43 subroutines return no status unless a namelist read or write is
44 being done, in which case there is the usual status. No further
45 calls are necessary in this case.
47 For other sorts of data transfer, there are zero or more data
48 transfer statement that depend on the format of the data transfer
49 statement. For READ (and for backwards compatibily: for WRITE), one has
54 transfer_character_wide
62 transfer_integer_write
63 transfer_logical_write
64 transfer_character_write
65 transfer_character_wide_write
67 transfer_complex_write
68 transfer_real128_write
69 transfer_complex128_write
71 These subroutines do not return status. The *128 functions
72 are in the file transfer128.c.
74 The last call is a call to st_[read|write]_done(). While
75 something can easily go wrong with the initial st_read() or
76 st_write(), an error inhibits any data from actually being
79 extern void transfer_integer (st_parameter_dt
*, void *, int);
80 export_proto(transfer_integer
);
82 extern void transfer_integer_write (st_parameter_dt
*, void *, int);
83 export_proto(transfer_integer_write
);
85 extern void transfer_real (st_parameter_dt
*, void *, int);
86 export_proto(transfer_real
);
88 extern void transfer_real_write (st_parameter_dt
*, void *, int);
89 export_proto(transfer_real_write
);
91 extern void transfer_logical (st_parameter_dt
*, void *, int);
92 export_proto(transfer_logical
);
94 extern void transfer_logical_write (st_parameter_dt
*, void *, int);
95 export_proto(transfer_logical_write
);
97 extern void transfer_character (st_parameter_dt
*, void *, gfc_charlen_type
);
98 export_proto(transfer_character
);
100 extern void transfer_character_write (st_parameter_dt
*, void *, gfc_charlen_type
);
101 export_proto(transfer_character_write
);
103 extern void transfer_character_wide (st_parameter_dt
*, void *, gfc_charlen_type
, int);
104 export_proto(transfer_character_wide
);
106 extern void transfer_character_wide_write (st_parameter_dt
*,
107 void *, gfc_charlen_type
, int);
108 export_proto(transfer_character_wide_write
);
110 extern void transfer_complex (st_parameter_dt
*, void *, int);
111 export_proto(transfer_complex
);
113 extern void transfer_complex_write (st_parameter_dt
*, void *, int);
114 export_proto(transfer_complex_write
);
116 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
118 export_proto(transfer_array
);
120 extern void transfer_array_write (st_parameter_dt
*, gfc_array_char
*, int,
122 export_proto(transfer_array_write
);
124 /* User defined derived type input/output. */
126 transfer_derived (st_parameter_dt
*dtp
, void *dtio_source
, void *dtio_proc
);
127 export_proto(transfer_derived
);
130 transfer_derived_write (st_parameter_dt
*dtp
, void *dtio_source
, void *dtio_proc
);
131 export_proto(transfer_derived_write
);
133 static void us_read (st_parameter_dt
*, int);
134 static void us_write (st_parameter_dt
*, int);
135 static void next_record_r_unf (st_parameter_dt
*, int);
136 static void next_record_w_unf (st_parameter_dt
*, int);
138 static const st_option advance_opt
[] = {
139 {"yes", ADVANCE_YES
},
145 static const st_option decimal_opt
[] = {
146 {"point", DECIMAL_POINT
},
147 {"comma", DECIMAL_COMMA
},
151 static const st_option round_opt
[] = {
153 {"down", ROUND_DOWN
},
154 {"zero", ROUND_ZERO
},
155 {"nearest", ROUND_NEAREST
},
156 {"compatible", ROUND_COMPATIBLE
},
157 {"processor_defined", ROUND_PROCDEFINED
},
162 static const st_option sign_opt
[] = {
164 {"suppress", SIGN_SS
},
165 {"processor_defined", SIGN_S
},
169 static const st_option blank_opt
[] = {
170 {"null", BLANK_NULL
},
171 {"zero", BLANK_ZERO
},
175 static const st_option delim_opt
[] = {
176 {"apostrophe", DELIM_APOSTROPHE
},
177 {"quote", DELIM_QUOTE
},
178 {"none", DELIM_NONE
},
182 static const st_option pad_opt
[] = {
188 static const st_option async_opt
[] = {
195 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
196 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
202 current_mode (st_parameter_dt
*dtp
)
206 m
= FORM_UNSPECIFIED
;
208 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
210 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
211 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
213 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
215 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
216 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
218 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
220 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
221 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
228 /* Mid level data transfer statements. */
230 /* Read sequential file - internal unit */
233 read_sf_internal (st_parameter_dt
*dtp
, size_t *length
)
235 static char *empty_string
[0];
239 /* Zero size array gives internal unit len of 0. Nothing to read. */
240 if (dtp
->internal_unit_len
== 0
241 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
244 /* If we have seen an eor previously, return a length of 0. The
245 caller is responsible for correctly padding the input field. */
246 if (dtp
->u
.p
.sf_seen_eor
)
249 /* Just return something that isn't a NULL pointer, otherwise the
250 caller thinks an error occurred. */
251 return (char*) empty_string
;
254 /* There are some cases with mixed DTIO where we have read a character
255 and saved it in the last character buffer, so we need to backup. */
256 if (unlikely (dtp
->u
.p
.current_unit
->child_dtio
> 0 &&
257 dtp
->u
.p
.current_unit
->last_char
!= EOF
- 1))
259 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
260 sseek (dtp
->u
.p
.current_unit
->s
, -1, SEEK_CUR
);
264 if (is_char4_unit(dtp
))
266 gfc_char4_t
*p
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
,
268 base
= fbuf_alloc (dtp
->u
.p
.current_unit
, lorig
);
269 for (size_t i
= 0; i
< *length
; i
++, p
++)
270 base
[i
] = *p
> 255 ? '?' : (unsigned char) *p
;
273 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
275 if (unlikely (lorig
> *length
))
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
, size_t *length
)
308 static char *empty_string
[0];
313 /* If we have seen an eor previously, return a length of 0. The
314 caller is responsible for correctly padding the input field. */
315 if (dtp
->u
.p
.sf_seen_eor
)
318 /* Just return something that isn't a NULL pointer, otherwise the
319 caller thinks an error occurred. */
320 return (char*) empty_string
;
323 /* There are some cases with mixed DTIO where we have read a character
324 and saved it in the last character buffer, so we need to backup. */
325 if (unlikely (dtp
->u
.p
.current_unit
->child_dtio
> 0 &&
326 dtp
->u
.p
.current_unit
->last_char
!= EOF
- 1))
328 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
329 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
334 /* Read data into format buffer and scan through it. */
339 q
= fbuf_getc (dtp
->u
.p
.current_unit
);
342 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
343 && (q
== '\n' || q
== '\r'))
345 /* Unexpected end of line. Set the position. */
346 dtp
->u
.p
.sf_seen_eor
= 1;
348 /* If we see an EOR during non-advancing I/O, we need to skip
349 the rest of the I/O statement. Set the corresponding flag. */
350 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
351 dtp
->u
.p
.eor_condition
= 1;
353 /* If we encounter a CR, it might be a CRLF. */
354 if (q
== '\r') /* Probably a CRLF */
356 /* See if there is an LF. */
357 q2
= fbuf_getc (dtp
->u
.p
.current_unit
);
359 dtp
->u
.p
.sf_seen_eor
= 2;
360 else if (q2
!= EOF
) /* Oops, seek back. */
361 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
364 /* Without padding, terminate the I/O statement without assigning
365 the value. With padding, the value still needs to be assigned,
366 so we can just continue with a short read. */
367 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
369 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
376 /* Short circuit the read if a comma is found during numeric input.
377 The flag is set to zero during character reads so that commas in
378 strings are not ignored */
380 if (dtp
->u
.p
.sf_read_comma
== 1)
383 notify_std (&dtp
->common
, GFC_STD_GNU
,
384 "Comma in formatted numeric read.");
392 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
393 some other stuff. Set the relevant flags. */
394 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
398 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
400 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
406 dtp
->u
.p
.eor_condition
= 1;
411 else if (dtp
->u
.p
.advance_status
== ADVANCE_NO
412 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
413 || dtp
->u
.p
.current_unit
->bytes_left
414 == dtp
->u
.p
.current_unit
->recl
)
423 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
425 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
426 dtp
->u
.p
.current_unit
->has_size
)
427 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) n
;
429 /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
430 fbuf_getc might reallocate the buffer. So return current pointer
431 minus all the advances, which is n plus up to two characters
432 of newline or comma. */
433 return fbuf_getptr (dtp
->u
.p
.current_unit
)
434 - n
- dtp
->u
.p
.sf_seen_eor
- seen_comma
;
438 /* Function for reading the next couple of bytes from the current
439 file, advancing the current position. We return NULL on end of record or
440 end of file. This function is only for formatted I/O, unformatted uses
443 If the read is short, then it is because the current record does not
444 have enough data to satisfy the read request and the file was
445 opened with PAD=YES. The caller must assume tailing spaces for
449 read_block_form (st_parameter_dt
*dtp
, size_t *nbytes
)
454 if (!is_stream_io (dtp
))
456 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
458 /* For preconnected units with default record length, set bytes left
459 to unit record length and proceed, otherwise error. */
460 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
461 && dtp
->u
.p
.current_unit
->recl
== default_recl
)
462 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
465 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
466 && !is_internal_unit (dtp
))
468 /* Not enough data left. */
469 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
474 if (is_internal_unit(dtp
))
476 if (*nbytes
> 0 && dtp
->u
.p
.current_unit
->bytes_left
== 0)
478 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
480 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
487 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0))
494 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
498 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
499 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
500 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
502 if (is_internal_unit (dtp
))
503 source
= read_sf_internal (dtp
, nbytes
);
505 source
= read_sf (dtp
, nbytes
);
507 dtp
->u
.p
.current_unit
->strm_pos
+=
508 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
512 /* If we reach here, we can assume it's direct access. */
514 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
517 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
518 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
520 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
521 dtp
->u
.p
.current_unit
->has_size
)
522 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *nbytes
;
524 if (norig
!= *nbytes
)
526 /* Short read, this shouldn't happen. */
527 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
529 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
534 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
540 /* Read a block from a character(kind=4) internal unit, to be transferred into
541 a character(kind=4) variable. Note: Portions of this code borrowed from
544 read_block_form4 (st_parameter_dt
*dtp
, size_t *nbytes
)
546 static gfc_char4_t
*empty_string
[0];
550 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
551 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
553 /* Zero size array gives internal unit len of 0. Nothing to read. */
554 if (dtp
->internal_unit_len
== 0
555 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
558 /* If we have seen an eor previously, return a length of 0. The
559 caller is responsible for correctly padding the input field. */
560 if (dtp
->u
.p
.sf_seen_eor
)
563 /* Just return something that isn't a NULL pointer, otherwise the
564 caller thinks an error occurred. */
569 source
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
, nbytes
);
571 if (unlikely (lorig
> *nbytes
))
577 dtp
->u
.p
.current_unit
->bytes_left
-= *nbytes
;
579 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
580 dtp
->u
.p
.current_unit
->has_size
)
581 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *nbytes
;
587 /* Reads a block directly into application data space. This is for
588 unformatted files. */
591 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
593 ssize_t to_read_record
;
594 ssize_t have_read_record
;
595 ssize_t to_read_subrecord
;
596 ssize_t have_read_subrecord
;
599 if (is_stream_io (dtp
))
601 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
603 if (unlikely (have_read_record
< 0))
605 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
609 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
611 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
613 /* Short read, e.g. if we hit EOF. For stream files,
614 we have to set the end-of-file condition. */
620 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
622 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
625 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
626 nbytes
= to_read_record
;
631 to_read_record
= nbytes
;
634 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
636 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
637 if (unlikely (to_read_record
< 0))
639 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
643 if (to_read_record
!= (ssize_t
) nbytes
)
645 /* Short read, e.g. if we hit EOF. Apparently, we read
646 more than was written to the last record. */
650 if (unlikely (short_record
))
652 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
657 /* Unformatted sequential. We loop over the subrecords, reading
658 until the request has been fulfilled or the record has run out
659 of continuation subrecords. */
661 /* Check whether we exceed the total record length. */
663 if (dtp
->u
.p
.current_unit
->flags
.has_recl
664 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
666 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
671 to_read_record
= nbytes
;
674 have_read_record
= 0;
678 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
679 < (gfc_offset
) to_read_record
)
681 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
682 to_read_record
-= to_read_subrecord
;
686 to_read_subrecord
= to_read_record
;
690 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
692 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
693 buf
+ have_read_record
, to_read_subrecord
);
694 if (unlikely (have_read_subrecord
< 0))
696 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
700 have_read_record
+= have_read_subrecord
;
702 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
704 /* Short read, e.g. if we hit EOF. This means the record
705 structure has been corrupted, or the trailing record
706 marker would still be present. */
708 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
712 if (to_read_record
> 0)
714 if (likely (dtp
->u
.p
.current_unit
->continued
))
716 next_record_r_unf (dtp
, 0);
721 /* Let's make sure the file position is correctly pre-positioned
722 for the next read statement. */
724 dtp
->u
.p
.current_unit
->current_record
= 0;
725 next_record_r_unf (dtp
, 0);
726 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
732 /* Normal exit, the read request has been fulfilled. */
737 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
738 if (unlikely (short_record
))
740 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
747 /* Function for writing a block of bytes to the current file at the
748 current position, advancing the file pointer. We are given a length
749 and return a pointer to a buffer that the caller must (completely)
750 fill in. Returns NULL on error. */
753 write_block (st_parameter_dt
*dtp
, size_t length
)
757 if (!is_stream_io (dtp
))
759 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
761 /* For preconnected units with default record length, set bytes left
762 to unit record length and proceed, otherwise error. */
763 if (likely ((dtp
->u
.p
.current_unit
->unit_number
764 == options
.stdout_unit
765 || dtp
->u
.p
.current_unit
->unit_number
766 == options
.stderr_unit
)
767 && dtp
->u
.p
.current_unit
->recl
== default_recl
))
768 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
771 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
776 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
779 if (is_internal_unit (dtp
))
781 if (is_char4_unit(dtp
)) /* char4 internel unit. */
784 dest4
= mem_alloc_w4 (dtp
->u
.p
.current_unit
->s
, &length
);
787 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
793 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
797 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
801 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
802 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
806 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
809 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
814 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
815 dtp
->u
.p
.current_unit
->has_size
)
816 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) length
;
818 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
824 /* High level interface to swrite(), taking care of errors. This is only
825 called for unformatted files. There are three cases to consider:
826 Stream I/O, unformatted direct, unformatted sequential. */
829 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
832 ssize_t have_written
;
833 ssize_t to_write_subrecord
;
838 if (is_stream_io (dtp
))
840 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
841 if (unlikely (have_written
< 0))
843 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
847 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
852 /* Unformatted direct access. */
854 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
856 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
858 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
862 if (buf
== NULL
&& nbytes
== 0)
865 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
866 if (unlikely (have_written
< 0))
868 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
872 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
873 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
878 /* Unformatted sequential. */
882 if (dtp
->u
.p
.current_unit
->flags
.has_recl
883 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
885 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
897 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
898 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
900 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
901 (gfc_offset
) to_write_subrecord
;
903 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
904 buf
+ have_written
, to_write_subrecord
);
905 if (unlikely (to_write_subrecord
< 0))
907 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
911 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
912 nbytes
-= to_write_subrecord
;
913 have_written
+= to_write_subrecord
;
918 next_record_w_unf (dtp
, 1);
921 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
922 if (unlikely (short_record
))
924 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
931 /* Reverse memcpy - used for byte swapping. */
934 reverse_memcpy (void *dest
, const void *src
, size_t n
)
940 s
= (char *) src
+ n
- 1;
942 /* Write with ascending order - this is likely faster
943 on modern architectures because of write combining. */
949 /* Utility function for byteswapping an array, using the bswap
950 builtins if possible. dest and src can overlap completely, or then
951 they must point to separate objects; partial overlaps are not
955 bswap_array (void *dest
, const void *src
, size_t size
, size_t nelems
)
965 for (size_t i
= 0; i
< nelems
; i
++)
966 ((uint16_t*)dest
)[i
] = __builtin_bswap16 (((uint16_t*)src
)[i
]);
969 for (size_t i
= 0; i
< nelems
; i
++)
970 ((uint32_t*)dest
)[i
] = __builtin_bswap32 (((uint32_t*)src
)[i
]);
973 for (size_t i
= 0; i
< nelems
; i
++)
974 ((uint64_t*)dest
)[i
] = __builtin_bswap64 (((uint64_t*)src
)[i
]);
979 for (size_t i
= 0; i
< nelems
; i
++)
982 memcpy (&tmp
, ps
, 4);
983 *(uint32_t*)pd
= __builtin_bswap32 (*(uint32_t*)(ps
+ 8));
984 *(uint32_t*)(pd
+ 4) = __builtin_bswap32 (*(uint32_t*)(ps
+ 4));
985 *(uint32_t*)(pd
+ 8) = __builtin_bswap32 (tmp
);
993 for (size_t i
= 0; i
< nelems
; i
++)
996 memcpy (&tmp
, ps
, 8);
997 *(uint64_t*)pd
= __builtin_bswap64 (*(uint64_t*)(ps
+ 8));
998 *(uint64_t*)(pd
+ 8) = __builtin_bswap64 (tmp
);
1008 for (size_t i
= 0; i
< nelems
; i
++)
1010 reverse_memcpy (pd
, ps
, size
);
1017 /* In-place byte swap. */
1018 for (size_t i
= 0; i
< nelems
; i
++)
1020 char tmp
, *low
= pd
, *high
= pd
+ size
- 1;
1021 for (size_t j
= 0; j
< size
/2; j
++)
1036 /* Master function for unformatted reads. */
1039 unformatted_read (st_parameter_dt
*dtp
, bt type
,
1040 void *dest
, int kind
, size_t size
, size_t nelems
)
1042 if (type
== BT_CLASS
)
1044 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1045 char tmp_iomsg
[IOMSG_LEN
] = "";
1047 gfc_charlen_type child_iomsg_len
;
1049 int *child_iostat
= NULL
;
1051 /* Set iostat, intent(out). */
1053 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1054 dtp
->common
.iostat
: &noiostat
;
1056 /* Set iomsg, intent(inout). */
1057 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1059 child_iomsg
= dtp
->common
.iomsg
;
1060 child_iomsg_len
= dtp
->common
.iomsg_len
;
1064 child_iomsg
= tmp_iomsg
;
1065 child_iomsg_len
= IOMSG_LEN
;
1068 /* Call the user defined unformatted READ procedure. */
1069 dtp
->u
.p
.current_unit
->child_dtio
++;
1070 dtp
->u
.p
.ufdtio_ptr (dest
, &unit
, child_iostat
, child_iomsg
,
1072 dtp
->u
.p
.current_unit
->child_dtio
--;
1076 if (type
== BT_CHARACTER
)
1077 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
1078 read_block_direct (dtp
, dest
, size
* nelems
);
1080 if (unlikely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_SWAP
)
1083 /* Handle wide chracters. */
1084 if (type
== BT_CHARACTER
)
1090 /* Break up complex into its constituent reals. */
1091 else if (type
== BT_COMPLEX
)
1096 bswap_array (dest
, dest
, size
, nelems
);
1101 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
1102 bytes on 64 bit machines. The unused bytes are not initialized and never
1103 used, which can show an error with memory checking analyzers like
1104 valgrind. We us BT_CLASS to denote a User Defined I/O call. */
1107 unformatted_write (st_parameter_dt
*dtp
, bt type
,
1108 void *source
, int kind
, size_t size
, size_t nelems
)
1110 if (type
== BT_CLASS
)
1112 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1113 char tmp_iomsg
[IOMSG_LEN
] = "";
1115 gfc_charlen_type child_iomsg_len
;
1117 int *child_iostat
= NULL
;
1119 /* Set iostat, intent(out). */
1121 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1122 dtp
->common
.iostat
: &noiostat
;
1124 /* Set iomsg, intent(inout). */
1125 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1127 child_iomsg
= dtp
->common
.iomsg
;
1128 child_iomsg_len
= dtp
->common
.iomsg_len
;
1132 child_iomsg
= tmp_iomsg
;
1133 child_iomsg_len
= IOMSG_LEN
;
1136 /* Call the user defined unformatted WRITE procedure. */
1137 dtp
->u
.p
.current_unit
->child_dtio
++;
1138 dtp
->u
.p
.ufdtio_ptr (source
, &unit
, child_iostat
, child_iomsg
,
1140 dtp
->u
.p
.current_unit
->child_dtio
--;
1144 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1147 size_t stride
= type
== BT_CHARACTER
?
1148 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1150 write_buf (dtp
, source
, stride
* nelems
);
1154 #define BSWAP_BUFSZ 512
1155 char buffer
[BSWAP_BUFSZ
];
1161 /* Handle wide chracters. */
1162 if (type
== BT_CHARACTER
&& kind
!= 1)
1168 /* Break up complex into its constituent reals. */
1169 if (type
== BT_COMPLEX
)
1175 /* By now, all complex variables have been split into their
1176 constituent reals. */
1182 if (size
* nrem
> BSWAP_BUFSZ
)
1183 nc
= BSWAP_BUFSZ
/ size
;
1187 bswap_array (buffer
, p
, size
, nc
);
1188 write_buf (dtp
, buffer
, size
* nc
);
1197 /* Return a pointer to the name of a type. */
1222 p
= "CLASS or DERIVED";
1225 internal_error (NULL
, "type_name(): Bad type");
1232 /* Write a constant string to the output.
1233 This is complicated because the string can have doubled delimiters
1234 in it. The length in the format node is the true length. */
1237 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
1239 char c
, delimiter
, *p
, *q
;
1242 length
= f
->u
.string
.length
;
1246 p
= write_block (dtp
, length
);
1253 for (; length
> 0; length
--)
1256 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
1257 q
++; /* Skip the doubled delimiter. */
1262 /* Given actual and expected types in a formatted data transfer, make
1263 sure they agree. If not, an error message is generated. Returns
1264 nonzero if something went wrong. */
1267 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
1270 char buffer
[BUFLEN
];
1272 if (actual
== expected
)
1275 /* Adjust item_count before emitting error message. */
1276 snprintf (buffer
, BUFLEN
,
1277 "Expected %s for item %d in formatted transfer, got %s",
1278 type_name (expected
), dtp
->u
.p
.item_count
- 1, type_name (actual
));
1280 format_error (dtp
, f
, buffer
);
1285 /* Check that the dtio procedure required for formatted IO is present. */
1288 check_dtio_proc (st_parameter_dt
*dtp
, const fnode
*f
)
1290 char buffer
[BUFLEN
];
1292 if (dtp
->u
.p
.fdtio_ptr
!= NULL
)
1295 snprintf (buffer
, BUFLEN
,
1296 "Missing DTIO procedure or intrinsic type passed for item %d "
1297 "in formatted transfer",
1298 dtp
->u
.p
.item_count
- 1);
1300 format_error (dtp
, f
, buffer
);
1306 require_numeric_type (st_parameter_dt
*dtp
, bt actual
, const fnode
*f
)
1309 char buffer
[BUFLEN
];
1311 if (actual
== BT_INTEGER
|| actual
== BT_REAL
|| actual
== BT_COMPLEX
)
1314 /* Adjust item_count before emitting error message. */
1315 snprintf (buffer
, BUFLEN
,
1316 "Expected numeric type for item %d in formatted transfer, got %s",
1317 dtp
->u
.p
.item_count
- 1, type_name (actual
));
1319 format_error (dtp
, f
, buffer
);
1324 get_dt_format (char *p
, gfc_charlen_type
*length
)
1326 char delim
= p
[-1]; /* The delimiter is always the first character back. */
1328 gfc_charlen_type len
= *length
; /* This length already correct, less 'DT'. */
1330 res
= q
= xmalloc (len
+ 2);
1332 /* Set the beginning of the string to 'DT', length adjusted below. */
1336 /* The string may contain doubled quotes so scan and skip as needed. */
1337 for (; len
> 0; len
--)
1341 p
++; /* Skip the doubled delimiter. */
1344 /* Adjust the string length by two now that we are done. */
1351 /* This function is in the main loop for a formatted data transfer
1352 statement. It would be natural to implement this as a coroutine
1353 with the user program, but C makes that awkward. We loop,
1354 processing format elements. When we actually have to transfer
1355 data instead of just setting flags, we return control to the user
1356 program which calls a function that supplies the address and type
1357 of the next element, then comes back here to process it. */
1360 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1363 int pos
, bytes_used
;
1367 int consume_data_flag
;
1369 /* Change a complex data item into a pair of reals. */
1371 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1372 if (type
== BT_COMPLEX
)
1378 /* If there's an EOR condition, we simulate finalizing the transfer
1379 by doing nothing. */
1380 if (dtp
->u
.p
.eor_condition
)
1383 /* Set this flag so that commas in reads cause the read to complete before
1384 the entire field has been read. The next read field will start right after
1385 the comma in the stream. (Set to 0 for character reads). */
1386 dtp
->u
.p
.sf_read_comma
=
1387 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1391 /* If reversion has occurred and there is another real data item,
1392 then we have to move to the next record. */
1393 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1395 dtp
->u
.p
.reversion_flag
= 0;
1396 next_record (dtp
, 0);
1399 consume_data_flag
= 1;
1400 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1403 f
= next_format (dtp
);
1406 /* No data descriptors left. */
1407 if (unlikely (n
> 0))
1408 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1409 "Insufficient data descriptors in format after reversion");
1415 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1416 - dtp
->u
.p
.current_unit
->bytes_left
);
1418 if (is_stream_io(dtp
))
1425 goto need_read_data
;
1426 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1428 read_decimal (dtp
, f
, p
, kind
);
1433 goto need_read_data
;
1434 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1435 && require_numeric_type (dtp
, type
, f
))
1437 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1438 && require_type (dtp
, BT_INTEGER
, type
, f
))
1440 read_radix (dtp
, f
, p
, kind
, 2);
1445 goto need_read_data
;
1446 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1447 && require_numeric_type (dtp
, type
, f
))
1449 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1450 && require_type (dtp
, BT_INTEGER
, type
, f
))
1452 read_radix (dtp
, f
, p
, kind
, 8);
1457 goto need_read_data
;
1458 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1459 && require_numeric_type (dtp
, type
, f
))
1461 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1462 && require_type (dtp
, BT_INTEGER
, type
, f
))
1464 read_radix (dtp
, f
, p
, kind
, 16);
1469 goto need_read_data
;
1471 /* It is possible to have FMT_A with something not BT_CHARACTER such
1472 as when writing out hollerith strings, so check both type
1473 and kind before calling wide character routines. */
1474 if (type
== BT_CHARACTER
&& kind
== 4)
1475 read_a_char4 (dtp
, f
, p
, size
);
1477 read_a (dtp
, f
, p
, size
);
1482 goto need_read_data
;
1483 read_l (dtp
, f
, p
, kind
);
1488 goto need_read_data
;
1489 if (require_type (dtp
, BT_REAL
, type
, f
))
1491 read_f (dtp
, f
, p
, kind
);
1496 goto need_read_data
;
1498 if (check_dtio_proc (dtp
, f
))
1500 if (require_type (dtp
, BT_CLASS
, type
, f
))
1502 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1504 char tmp_iomsg
[IOMSG_LEN
] = "";
1506 gfc_charlen_type child_iomsg_len
;
1508 int *child_iostat
= NULL
;
1510 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1512 /* Build the iotype string. */
1513 if (iotype_len
== 0)
1519 iotype
= get_dt_format (f
->u
.udf
.string
, &iotype_len
);
1521 /* Set iostat, intent(out). */
1523 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1524 dtp
->common
.iostat
: &noiostat
;
1526 /* Set iomsg, intent(inout). */
1527 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1529 child_iomsg
= dtp
->common
.iomsg
;
1530 child_iomsg_len
= dtp
->common
.iomsg_len
;
1534 child_iomsg
= tmp_iomsg
;
1535 child_iomsg_len
= IOMSG_LEN
;
1538 /* Call the user defined formatted READ procedure. */
1539 dtp
->u
.p
.current_unit
->child_dtio
++;
1540 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
1541 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1542 child_iostat
, child_iomsg
,
1543 iotype_len
, child_iomsg_len
);
1544 dtp
->u
.p
.current_unit
->child_dtio
--;
1546 if (f
->u
.udf
.string_len
!= 0)
1548 /* Note: vlist is freed in free_format_data. */
1553 goto need_read_data
;
1554 if (require_type (dtp
, BT_REAL
, type
, f
))
1556 read_f (dtp
, f
, p
, kind
);
1561 goto need_read_data
;
1562 if (require_type (dtp
, BT_REAL
, type
, f
))
1564 read_f (dtp
, f
, p
, kind
);
1569 goto need_read_data
;
1570 if (require_type (dtp
, BT_REAL
, type
, f
))
1572 read_f (dtp
, f
, p
, kind
);
1577 goto need_read_data
;
1578 if (require_type (dtp
, BT_REAL
, type
, f
))
1580 read_f (dtp
, f
, p
, kind
);
1585 goto need_read_data
;
1589 read_decimal (dtp
, f
, p
, kind
);
1592 read_l (dtp
, f
, p
, kind
);
1596 read_a_char4 (dtp
, f
, p
, size
);
1598 read_a (dtp
, f
, p
, size
);
1601 read_f (dtp
, f
, p
, kind
);
1604 internal_error (&dtp
->common
,
1605 "formatted_transfer (): Bad type");
1610 consume_data_flag
= 0;
1611 format_error (dtp
, f
, "Constant string in input format");
1614 /* Format codes that don't transfer data. */
1617 consume_data_flag
= 0;
1618 dtp
->u
.p
.skips
+= f
->u
.n
;
1619 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1620 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1621 read_x (dtp
, f
->u
.n
);
1626 consume_data_flag
= 0;
1628 if (f
->format
== FMT_TL
)
1630 /* Handle the special case when no bytes have been used yet.
1631 Cannot go below zero. */
1632 if (bytes_used
== 0)
1634 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1635 dtp
->u
.p
.skips
-= f
->u
.n
;
1636 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1639 pos
= bytes_used
- f
->u
.n
;
1644 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1645 left tab limit. We do not check if the position has gone
1646 beyond the end of record because a subsequent tab could
1647 bring us back again. */
1648 pos
= pos
< 0 ? 0 : pos
;
1650 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1651 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1652 + pos
- dtp
->u
.p
.max_pos
;
1653 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1654 ? 0 : dtp
->u
.p
.pending_spaces
;
1655 if (dtp
->u
.p
.skips
== 0)
1658 /* Adjust everything for end-of-record condition */
1659 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1661 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1662 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1664 if (dtp
->u
.p
.pending_spaces
== 0)
1665 dtp
->u
.p
.sf_seen_eor
= 0;
1667 if (dtp
->u
.p
.skips
< 0)
1669 if (is_internal_unit (dtp
))
1670 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1672 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1673 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1674 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1677 read_x (dtp
, dtp
->u
.p
.skips
);
1681 consume_data_flag
= 0;
1682 dtp
->u
.p
.sign_status
= SIGN_S
;
1686 consume_data_flag
= 0;
1687 dtp
->u
.p
.sign_status
= SIGN_SS
;
1691 consume_data_flag
= 0;
1692 dtp
->u
.p
.sign_status
= SIGN_SP
;
1696 consume_data_flag
= 0 ;
1697 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1701 consume_data_flag
= 0;
1702 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1706 consume_data_flag
= 0;
1707 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1711 consume_data_flag
= 0;
1712 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1716 consume_data_flag
= 0;
1717 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1721 consume_data_flag
= 0;
1722 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1726 consume_data_flag
= 0;
1727 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1731 consume_data_flag
= 0;
1732 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1736 consume_data_flag
= 0;
1737 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1741 consume_data_flag
= 0;
1742 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1746 consume_data_flag
= 0;
1747 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1751 consume_data_flag
= 0;
1752 dtp
->u
.p
.seen_dollar
= 1;
1756 consume_data_flag
= 0;
1757 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1758 next_record (dtp
, 0);
1762 /* A colon descriptor causes us to exit this loop (in
1763 particular preventing another / descriptor from being
1764 processed) unless there is another data item to be
1766 consume_data_flag
= 0;
1772 internal_error (&dtp
->common
, "Bad format node");
1775 /* Adjust the item count and data pointer. */
1777 if ((consume_data_flag
> 0) && (n
> 0))
1780 p
= ((char *) p
) + size
;
1785 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1786 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1791 /* Come here when we need a data descriptor but don't have one. We
1792 push the current format node back onto the input, then return and
1793 let the user program call us back with the data. */
1795 unget_format (dtp
, f
);
1800 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1803 gfc_offset pos
, bytes_used
;
1807 int consume_data_flag
;
1809 /* Change a complex data item into a pair of reals. */
1811 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1812 if (type
== BT_COMPLEX
)
1818 /* If there's an EOR condition, we simulate finalizing the transfer
1819 by doing nothing. */
1820 if (dtp
->u
.p
.eor_condition
)
1823 /* Set this flag so that commas in reads cause the read to complete before
1824 the entire field has been read. The next read field will start right after
1825 the comma in the stream. (Set to 0 for character reads). */
1826 dtp
->u
.p
.sf_read_comma
=
1827 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1831 /* If reversion has occurred and there is another real data item,
1832 then we have to move to the next record. */
1833 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1835 dtp
->u
.p
.reversion_flag
= 0;
1836 next_record (dtp
, 0);
1839 consume_data_flag
= 1;
1840 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1843 f
= next_format (dtp
);
1846 /* No data descriptors left. */
1847 if (unlikely (n
> 0))
1848 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1849 "Insufficient data descriptors in format after reversion");
1853 /* Now discharge T, TR and X movements to the right. This is delayed
1854 until a data producing format to suppress trailing spaces. */
1857 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1858 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1859 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1860 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1861 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
1863 || t
== FMT_STRING
))
1865 if (dtp
->u
.p
.skips
> 0)
1868 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1869 tmp
= dtp
->u
.p
.current_unit
->recl
1870 - dtp
->u
.p
.current_unit
->bytes_left
;
1872 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1875 if (dtp
->u
.p
.skips
< 0)
1877 if (is_internal_unit (dtp
))
1878 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1880 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1881 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1883 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1886 bytes_used
= dtp
->u
.p
.current_unit
->recl
1887 - dtp
->u
.p
.current_unit
->bytes_left
;
1889 if (is_stream_io(dtp
))
1897 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1899 write_i (dtp
, f
, p
, kind
);
1905 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1906 && require_numeric_type (dtp
, type
, f
))
1908 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1909 && require_type (dtp
, BT_INTEGER
, type
, f
))
1911 write_b (dtp
, f
, p
, kind
);
1917 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1918 && require_numeric_type (dtp
, type
, f
))
1920 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1921 && require_type (dtp
, BT_INTEGER
, type
, f
))
1923 write_o (dtp
, f
, p
, kind
);
1929 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1930 && require_numeric_type (dtp
, type
, f
))
1932 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1933 && require_type (dtp
, BT_INTEGER
, type
, f
))
1935 write_z (dtp
, f
, p
, kind
);
1942 /* It is possible to have FMT_A with something not BT_CHARACTER such
1943 as when writing out hollerith strings, so check both type
1944 and kind before calling wide character routines. */
1945 if (type
== BT_CHARACTER
&& kind
== 4)
1946 write_a_char4 (dtp
, f
, p
, size
);
1948 write_a (dtp
, f
, p
, size
);
1954 write_l (dtp
, f
, p
, kind
);
1960 if (require_type (dtp
, BT_REAL
, type
, f
))
1962 write_d (dtp
, f
, p
, kind
);
1968 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1970 char tmp_iomsg
[IOMSG_LEN
] = "";
1972 gfc_charlen_type child_iomsg_len
;
1974 int *child_iostat
= NULL
;
1976 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1978 /* Build the iotype string. */
1979 if (iotype_len
== 0)
1985 iotype
= get_dt_format (f
->u
.udf
.string
, &iotype_len
);
1987 /* Set iostat, intent(out). */
1989 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1990 dtp
->common
.iostat
: &noiostat
;
1992 /* Set iomsg, intent(inout). */
1993 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1995 child_iomsg
= dtp
->common
.iomsg
;
1996 child_iomsg_len
= dtp
->common
.iomsg_len
;
2000 child_iomsg
= tmp_iomsg
;
2001 child_iomsg_len
= IOMSG_LEN
;
2004 if (check_dtio_proc (dtp
, f
))
2007 /* Call the user defined formatted WRITE procedure. */
2008 dtp
->u
.p
.current_unit
->child_dtio
++;
2010 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
2011 child_iostat
, child_iomsg
,
2012 iotype_len
, child_iomsg_len
);
2013 dtp
->u
.p
.current_unit
->child_dtio
--;
2015 if (f
->u
.udf
.string_len
!= 0)
2017 /* Note: vlist is freed in free_format_data. */
2023 if (require_type (dtp
, BT_REAL
, type
, f
))
2025 write_e (dtp
, f
, p
, kind
);
2031 if (require_type (dtp
, BT_REAL
, type
, f
))
2033 write_en (dtp
, f
, p
, kind
);
2039 if (require_type (dtp
, BT_REAL
, type
, f
))
2041 write_es (dtp
, f
, p
, kind
);
2047 if (require_type (dtp
, BT_REAL
, type
, f
))
2049 write_f (dtp
, f
, p
, kind
);
2058 write_i (dtp
, f
, p
, kind
);
2061 write_l (dtp
, f
, p
, kind
);
2065 write_a_char4 (dtp
, f
, p
, size
);
2067 write_a (dtp
, f
, p
, size
);
2070 if (f
->u
.real
.w
== 0)
2071 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
2073 write_d (dtp
, f
, p
, kind
);
2076 internal_error (&dtp
->common
,
2077 "formatted_transfer (): Bad type");
2082 consume_data_flag
= 0;
2083 write_constant_string (dtp
, f
);
2086 /* Format codes that don't transfer data. */
2089 consume_data_flag
= 0;
2091 dtp
->u
.p
.skips
+= f
->u
.n
;
2092 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
2093 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
2094 /* Writes occur just before the switch on f->format, above, so
2095 that trailing blanks are suppressed, unless we are doing a
2096 non-advancing write in which case we want to output the blanks
2098 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2100 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
2101 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2107 consume_data_flag
= 0;
2109 if (f
->format
== FMT_TL
)
2112 /* Handle the special case when no bytes have been used yet.
2113 Cannot go below zero. */
2114 if (bytes_used
== 0)
2116 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
2117 dtp
->u
.p
.skips
-= f
->u
.n
;
2118 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
2121 pos
= bytes_used
- f
->u
.n
;
2124 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
2126 /* Standard 10.6.1.1: excessive left tabbing is reset to the
2127 left tab limit. We do not check if the position has gone
2128 beyond the end of record because a subsequent tab could
2129 bring us back again. */
2130 pos
= pos
< 0 ? 0 : pos
;
2132 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
2133 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
2134 + pos
- dtp
->u
.p
.max_pos
;
2135 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
2136 ? 0 : dtp
->u
.p
.pending_spaces
;
2140 consume_data_flag
= 0;
2141 dtp
->u
.p
.sign_status
= SIGN_S
;
2145 consume_data_flag
= 0;
2146 dtp
->u
.p
.sign_status
= SIGN_SS
;
2150 consume_data_flag
= 0;
2151 dtp
->u
.p
.sign_status
= SIGN_SP
;
2155 consume_data_flag
= 0 ;
2156 dtp
->u
.p
.blank_status
= BLANK_NULL
;
2160 consume_data_flag
= 0;
2161 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
2165 consume_data_flag
= 0;
2166 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
2170 consume_data_flag
= 0;
2171 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
2175 consume_data_flag
= 0;
2176 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
2180 consume_data_flag
= 0;
2181 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
2185 consume_data_flag
= 0;
2186 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
2190 consume_data_flag
= 0;
2191 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
2195 consume_data_flag
= 0;
2196 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
2200 consume_data_flag
= 0;
2201 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
2205 consume_data_flag
= 0;
2206 dtp
->u
.p
.scale_factor
= f
->u
.k
;
2210 consume_data_flag
= 0;
2211 dtp
->u
.p
.seen_dollar
= 1;
2215 consume_data_flag
= 0;
2216 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2217 next_record (dtp
, 0);
2221 /* A colon descriptor causes us to exit this loop (in
2222 particular preventing another / descriptor from being
2223 processed) unless there is another data item to be
2225 consume_data_flag
= 0;
2231 internal_error (&dtp
->common
, "Bad format node");
2234 /* Adjust the item count and data pointer. */
2236 if ((consume_data_flag
> 0) && (n
> 0))
2239 p
= ((char *) p
) + size
;
2242 pos
= dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
;
2243 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
2248 /* Come here when we need a data descriptor but don't have one. We
2249 push the current format node back onto the input, then return and
2250 let the user program call us back with the data. */
2252 unget_format (dtp
, f
);
2255 /* This function is first called from data_init_transfer to initiate the loop
2256 over each item in the format, transferring data as required. Subsequent
2257 calls to this function occur for each data item foound in the READ/WRITE
2258 statement. The item_count is incremented for each call. Since the first
2259 call is from data_transfer_init, the item_count is always one greater than
2260 the actual count number of the item being transferred. */
2263 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2264 size_t size
, size_t nelems
)
2270 size_t stride
= type
== BT_CHARACTER
?
2271 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2272 if (dtp
->u
.p
.mode
== READING
)
2274 /* Big loop over all the elements. */
2275 for (elem
= 0; elem
< nelems
; elem
++)
2277 dtp
->u
.p
.item_count
++;
2278 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2283 /* Big loop over all the elements. */
2284 for (elem
= 0; elem
< nelems
; elem
++)
2286 dtp
->u
.p
.item_count
++;
2287 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2292 /* Wrapper function for I/O of scalar types. If this should be an async I/O
2293 request, queue it. For a synchronous write on an async unit, perform the
2294 wait operation and return an error. For all synchronous writes, call the
2295 right transfer function. */
2298 wrap_scalar_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2299 size_t size
, size_t n_elem
)
2301 if (dtp
->u
.p
.current_unit
&& dtp
->u
.p
.current_unit
->au
)
2306 args
.scalar
.transfer
= dtp
->u
.p
.transfer
;
2307 args
.scalar
.arg_bt
= type
;
2308 args
.scalar
.data
= p
;
2309 args
.scalar
.i
= kind
;
2310 args
.scalar
.s1
= size
;
2311 args
.scalar
.s2
= n_elem
;
2312 enqueue_transfer (dtp
->u
.p
.current_unit
->au
, &args
,
2313 AIO_TRANSFER_SCALAR
);
2317 /* Come here if there was no asynchronous I/O to be scheduled. */
2318 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2321 dtp
->u
.p
.transfer (dtp
, type
, p
, kind
, size
, 1);
2325 /* Data transfer entry points. The type of the data entity is
2326 implicit in the subroutine call. This prevents us from having to
2327 share a common enum with the compiler. */
2330 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
2332 wrap_scalar_transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
2336 transfer_integer_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2338 transfer_integer (dtp
, p
, kind
);
2342 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
2345 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2347 size
= size_from_real_kind (kind
);
2348 wrap_scalar_transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
2352 transfer_real_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2354 transfer_real (dtp
, p
, kind
);
2358 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
2360 wrap_scalar_transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
2364 transfer_logical_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2366 transfer_logical (dtp
, p
, kind
);
2370 transfer_character (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
)
2372 static char *empty_string
[0];
2374 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2377 /* Strings of zero length can have p == NULL, which confuses the
2378 transfer routines into thinking we need more data elements. To avoid
2379 this, we give them a nice pointer. */
2380 if (len
== 0 && p
== NULL
)
2383 /* Set kind here to 1. */
2384 wrap_scalar_transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
2388 transfer_character_write (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
)
2390 transfer_character (dtp
, p
, len
);
2394 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
, int kind
)
2396 static char *empty_string
[0];
2398 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2401 /* Strings of zero length can have p == NULL, which confuses the
2402 transfer routines into thinking we need more data elements. To avoid
2403 this, we give them a nice pointer. */
2404 if (len
== 0 && p
== NULL
)
2407 /* Here we pass the actual kind value. */
2408 wrap_scalar_transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
2412 transfer_character_wide_write (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
, int kind
)
2414 transfer_character_wide (dtp
, p
, len
, kind
);
2418 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
2421 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2423 size
= size_from_complex_kind (kind
);
2424 wrap_scalar_transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
2428 transfer_complex_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2430 transfer_complex (dtp
, p
, kind
);
2434 transfer_array_inner (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2435 gfc_charlen_type charlen
)
2437 index_type count
[GFC_MAX_DIMENSIONS
];
2438 index_type extent
[GFC_MAX_DIMENSIONS
];
2439 index_type stride
[GFC_MAX_DIMENSIONS
];
2440 index_type stride0
, rank
, size
, n
;
2445 /* Adjust item_count before emitting error message. */
2447 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2450 iotype
= (bt
) GFC_DESCRIPTOR_TYPE (desc
);
2451 size
= iotype
== BT_CHARACTER
? (index_type
) charlen
: GFC_DESCRIPTOR_SIZE (desc
);
2453 rank
= GFC_DESCRIPTOR_RANK (desc
);
2455 for (n
= 0; n
< rank
; n
++)
2458 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
2459 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
2461 /* If the extent of even one dimension is zero, then the entire
2462 array section contains zero elements, so we return after writing
2463 a zero array record. */
2468 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2473 stride0
= stride
[0];
2475 /* If the innermost dimension has a stride of 1, we can do the transfer
2476 in contiguous chunks. */
2477 if (stride0
== size
)
2482 data
= GFC_DESCRIPTOR_DATA (desc
);
2486 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2487 data
+= stride0
* tsize
;
2490 while (count
[n
] == extent
[n
])
2493 data
-= stride
[n
] * extent
[n
];
2510 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2511 gfc_charlen_type charlen
)
2513 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2516 if (dtp
->u
.p
.current_unit
&& dtp
->u
.p
.current_unit
->au
)
2521 size_t sz
= sizeof (gfc_array_char
)
2522 + sizeof (descriptor_dimension
)
2523 * GFC_DESCRIPTOR_RANK (desc
);
2524 args
.array
.desc
= xmalloc (sz
);
2525 NOTE ("desc = %p", (void *) args
.array
.desc
);
2526 memcpy (args
.array
.desc
, desc
, sz
);
2527 args
.array
.kind
= kind
;
2528 args
.array
.charlen
= charlen
;
2529 enqueue_transfer (dtp
->u
.p
.current_unit
->au
, &args
,
2530 AIO_TRANSFER_ARRAY
);
2534 /* Come here if there was no asynchronous I/O to be scheduled. */
2535 transfer_array_inner (dtp
, desc
, kind
, charlen
);
2540 transfer_array_write (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2541 gfc_charlen_type charlen
)
2543 transfer_array (dtp
, desc
, kind
, charlen
);
2547 /* User defined input/output iomsg. */
2549 #define IOMSG_LEN 256
2552 transfer_derived (st_parameter_dt
*parent
, void *dtio_source
, void *dtio_proc
)
2554 if (parent
->u
.p
.current_unit
)
2556 if (parent
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2557 parent
->u
.p
.ufdtio_ptr
= (unformatted_dtio
) dtio_proc
;
2559 parent
->u
.p
.fdtio_ptr
= (formatted_dtio
) dtio_proc
;
2561 wrap_scalar_transfer (parent
, BT_CLASS
, dtio_source
, 0, 0, 1);
2565 /* Preposition a sequential unformatted file while reading. */
2568 us_read (st_parameter_dt
*dtp
, int continued
)
2575 if (compile_options
.record_marker
== 0)
2576 n
= sizeof (GFC_INTEGER_4
);
2578 n
= compile_options
.record_marker
;
2580 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
2581 if (unlikely (nr
< 0))
2583 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2589 return; /* end of file */
2591 else if (unlikely (n
!= nr
))
2593 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2597 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2598 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2602 case sizeof(GFC_INTEGER_4
):
2603 memcpy (&i4
, &i
, sizeof (i4
));
2607 case sizeof(GFC_INTEGER_8
):
2608 memcpy (&i8
, &i
, sizeof (i8
));
2613 runtime_error ("Illegal value for record marker");
2623 case sizeof(GFC_INTEGER_4
):
2624 memcpy (&u32
, &i
, sizeof (u32
));
2625 u32
= __builtin_bswap32 (u32
);
2626 memcpy (&i4
, &u32
, sizeof (i4
));
2630 case sizeof(GFC_INTEGER_8
):
2631 memcpy (&u64
, &i
, sizeof (u64
));
2632 u64
= __builtin_bswap64 (u64
);
2633 memcpy (&i8
, &u64
, sizeof (i8
));
2638 runtime_error ("Illegal value for record marker");
2645 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
2646 dtp
->u
.p
.current_unit
->continued
= 0;
2650 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
2651 dtp
->u
.p
.current_unit
->continued
= 1;
2655 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2659 /* Preposition a sequential unformatted file while writing. This
2660 amount to writing a bogus length that will be filled in later. */
2663 us_write (st_parameter_dt
*dtp
, int continued
)
2670 if (compile_options
.record_marker
== 0)
2671 nbytes
= sizeof (GFC_INTEGER_4
);
2673 nbytes
= compile_options
.record_marker
;
2675 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2676 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2678 /* For sequential unformatted, if RECL= was not specified in the OPEN
2679 we write until we have more bytes than can fit in the subrecord
2680 markers, then we write a new subrecord. */
2682 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2683 dtp
->u
.p
.current_unit
->recl_subrecord
;
2684 dtp
->u
.p
.current_unit
->continued
= continued
;
2688 /* Position to the next record prior to transfer. We are assumed to
2689 be before the next record. We also calculate the bytes in the next
2693 pre_position (st_parameter_dt
*dtp
)
2695 if (dtp
->u
.p
.current_unit
->current_record
)
2696 return; /* Already positioned. */
2698 switch (current_mode (dtp
))
2700 case FORMATTED_STREAM
:
2701 case UNFORMATTED_STREAM
:
2702 /* There are no records with stream I/O. If the position was specified
2703 data_transfer_init has already positioned the file. If no position
2704 was specified, we continue from where we last left off. I.e.
2705 there is nothing to do here. */
2708 case UNFORMATTED_SEQUENTIAL
:
2709 if (dtp
->u
.p
.mode
== READING
)
2716 case FORMATTED_SEQUENTIAL
:
2717 case FORMATTED_DIRECT
:
2718 case UNFORMATTED_DIRECT
:
2719 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2723 dtp
->u
.p
.current_unit
->current_record
= 1;
2727 /* Initialize things for a data transfer. This code is common for
2728 both reading and writing. */
2731 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2733 unit_flags u_flags
; /* Used for creating a unit if needed. */
2734 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2735 namelist_info
*ionml
;
2738 NOTE ("data_transfer_init");
2740 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2742 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2744 dtp
->u
.p
.ionml
= ionml
;
2745 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2746 dtp
->u
.p
.namelist_mode
= 0;
2747 dtp
->u
.p
.cc
.len
= 0;
2749 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2752 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2754 if (dtp
->u
.p
.current_unit
== NULL
)
2756 /* This means we tried to access an external unit < 0 without
2757 having opened it first with NEWUNIT=. */
2758 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2759 "Unit number is negative and unit was not already "
2760 "opened with OPEN(NEWUNIT=...)");
2763 else if (dtp
->u
.p
.current_unit
->s
== NULL
)
2764 { /* Open the unit with some default flags. */
2765 st_parameter_open opp
;
2767 NOTE ("Open the unit with some default flags.");
2768 memset (&u_flags
, '\0', sizeof (u_flags
));
2769 u_flags
.access
= ACCESS_SEQUENTIAL
;
2770 u_flags
.action
= ACTION_READWRITE
;
2772 /* Is it unformatted? */
2773 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2774 | IOPARM_DT_IONML_SET
)))
2775 u_flags
.form
= FORM_UNFORMATTED
;
2777 u_flags
.form
= FORM_UNSPECIFIED
;
2779 u_flags
.delim
= DELIM_UNSPECIFIED
;
2780 u_flags
.blank
= BLANK_UNSPECIFIED
;
2781 u_flags
.pad
= PAD_UNSPECIFIED
;
2782 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2783 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2784 u_flags
.async
= ASYNC_UNSPECIFIED
;
2785 u_flags
.round
= ROUND_UNSPECIFIED
;
2786 u_flags
.sign
= SIGN_UNSPECIFIED
;
2787 u_flags
.share
= SHARE_UNSPECIFIED
;
2788 u_flags
.cc
= CC_UNSPECIFIED
;
2789 u_flags
.readonly
= 0;
2791 u_flags
.status
= STATUS_UNKNOWN
;
2793 conv
= get_unformatted_convert (dtp
->common
.unit
);
2795 if (conv
== GFC_CONVERT_NONE
)
2796 conv
= compile_options
.convert
;
2800 case GFC_CONVERT_NATIVE
:
2801 case GFC_CONVERT_SWAP
:
2804 case GFC_CONVERT_BIG
:
2805 conv
= __BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2808 case GFC_CONVERT_LITTLE
:
2809 conv
= __BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2813 internal_error (&opp
.common
, "Illegal value for CONVERT");
2817 u_flags
.convert
= conv
;
2819 opp
.common
= dtp
->common
;
2820 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2821 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2822 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2823 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2824 if (dtp
->u
.p
.current_unit
== NULL
)
2828 if (dtp
->u
.p
.current_unit
->child_dtio
== 0)
2830 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2832 dtp
->u
.p
.current_unit
->has_size
= true;
2833 /* Initialize the count. */
2834 dtp
->u
.p
.current_unit
->size_used
= 0;
2837 dtp
->u
.p
.current_unit
->has_size
= false;
2839 else if (dtp
->u
.p
.current_unit
->internal_unit_kind
> 0)
2840 dtp
->u
.p
.unit_is_internal
= 1;
2842 if ((cf
& IOPARM_DT_HAS_ASYNCHRONOUS
) != 0)
2845 f
= find_option (&dtp
->common
, dtp
->asynchronous
, dtp
->asynchronous_len
,
2846 async_opt
, "Bad ASYNCHRONOUS in data transfer "
2848 if (f
== ASYNC_YES
&& dtp
->u
.p
.current_unit
->flags
.async
!= ASYNC_YES
)
2850 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2851 "ASYNCHRONOUS transfer without "
2852 "ASYHCRONOUS='YES' in OPEN");
2855 dtp
->u
.p
.async
= f
== ASYNC_YES
;
2858 au
= dtp
->u
.p
.current_unit
->au
;
2863 /* If this is an asynchronous I/O statement, collect errors and
2864 return if there are any. */
2865 if (collect_async_errors (&dtp
->common
, au
))
2870 /* Synchronous statement: Perform a wait operation for any pending
2871 asynchronous I/O. This needs to be done before all other error
2872 checks. See F2008, 9.6.4.1. */
2873 if (async_wait (&(dtp
->common
), au
))
2878 /* Check the action. */
2880 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2882 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2883 "Cannot read from file opened for WRITE");
2887 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2889 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2890 "Cannot write to file opened for READ");
2894 dtp
->u
.p
.first_item
= 1;
2896 /* Check the format. */
2898 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2901 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2902 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2905 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2906 "Format present for UNFORMATTED data transfer");
2910 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2912 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2914 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2915 "A format cannot be specified with a namelist");
2919 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2920 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2922 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2923 "Missing format for FORMATTED data transfer");
2927 if (is_internal_unit (dtp
)
2928 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2930 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2931 "Internal file cannot be accessed by UNFORMATTED "
2936 /* Check the record or position number. */
2938 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2939 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2941 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2942 "Direct access data transfer requires record number");
2946 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2948 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2950 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2951 "Record number not allowed for sequential access "
2956 if (compile_options
.warn_std
&&
2957 dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
)
2959 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2960 "Sequential READ or WRITE not allowed after "
2961 "EOF marker, possibly use REWIND or BACKSPACE");
2966 /* Process the ADVANCE option. */
2968 dtp
->u
.p
.advance_status
2969 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2970 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2971 "Bad ADVANCE parameter in data transfer statement");
2973 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2975 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2977 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2978 "ADVANCE specification conflicts with sequential "
2983 if (is_internal_unit (dtp
))
2985 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2986 "ADVANCE specification conflicts with internal file");
2990 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2991 != IOPARM_DT_HAS_FORMAT
)
2993 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2994 "ADVANCE specification requires an explicit format");
2999 /* Child IO is non-advancing and any ADVANCE= specifier is ignored.
3001 if (dtp
->u
.p
.current_unit
->child_dtio
> 0)
3002 dtp
->u
.p
.advance_status
= ADVANCE_NO
;
3006 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
3008 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3010 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
3011 "EOR specification requires an ADVANCE specification "
3016 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
3017 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3019 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
3020 "SIZE specification requires an ADVANCE "
3021 "specification of NO");
3026 { /* Write constraints. */
3027 if ((cf
& IOPARM_END
) != 0)
3029 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3030 "END specification cannot appear in a write "
3035 if ((cf
& IOPARM_EOR
) != 0)
3037 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3038 "EOR specification cannot appear in a write "
3043 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
3045 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3046 "SIZE specification cannot appear in a write "
3052 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
3053 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
3055 /* Check the decimal mode. */
3056 dtp
->u
.p
.current_unit
->decimal_status
3057 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
3058 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
3059 decimal_opt
, "Bad DECIMAL parameter in data transfer "
3062 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
3063 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
3065 /* Check the round mode. */
3066 dtp
->u
.p
.current_unit
->round_status
3067 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
3068 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
3069 round_opt
, "Bad ROUND parameter in data transfer "
3072 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
3073 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
3075 /* Check the sign mode. */
3076 dtp
->u
.p
.sign_status
3077 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
3078 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
3079 "Bad SIGN parameter in data transfer statement");
3081 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
3082 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
3084 /* Check the blank mode. */
3085 dtp
->u
.p
.blank_status
3086 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
3087 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
3089 "Bad BLANK parameter in data transfer statement");
3091 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
3092 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
3094 /* Check the delim mode. */
3095 dtp
->u
.p
.current_unit
->delim_status
3096 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
3097 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
3098 delim_opt
, "Bad DELIM parameter in data transfer statement");
3100 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
3102 if (ionml
&& dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_UNSPECIFIED
)
3103 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
3105 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
3108 /* Check the pad mode. */
3109 dtp
->u
.p
.current_unit
->pad_status
3110 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
3111 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
3112 "Bad PAD parameter in data transfer statement");
3114 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
3115 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
3117 /* Set up the subroutine that will handle the transfers. */
3121 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3122 dtp
->u
.p
.transfer
= unformatted_read
;
3125 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3126 dtp
->u
.p
.transfer
= list_formatted_read
;
3128 dtp
->u
.p
.transfer
= formatted_transfer
;
3133 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3134 dtp
->u
.p
.transfer
= unformatted_write
;
3137 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3138 dtp
->u
.p
.transfer
= list_formatted_write
;
3140 dtp
->u
.p
.transfer
= formatted_transfer
;
3146 NOTE ("enqueue_data_transfer");
3147 enqueue_data_transfer_init (au
, dtp
, read_flag
);
3151 NOTE ("invoking data_transfer_init_worker");
3152 data_transfer_init_worker (dtp
, read_flag
);
3157 data_transfer_init_worker (st_parameter_dt
*dtp
, int read_flag
)
3159 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3161 NOTE ("starting worker...");
3163 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.form
!= FORM_UNFORMATTED
3164 && ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3165 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
3166 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
3168 /* Check to see if we might be reading what we wrote before */
3170 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
3171 && !is_internal_unit (dtp
))
3173 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
3175 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
3176 sflush(dtp
->u
.p
.current_unit
->s
);
3179 /* Check the POS= specifier: that it is in range and that it is used with a
3180 unit that has been connected for STREAM access. F2003 9.5.1.10. */
3182 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
3184 if (is_stream_io (dtp
))
3189 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3190 "POS=specifier must be positive");
3194 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
3196 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3197 "POS=specifier too large");
3201 dtp
->rec
= dtp
->pos
;
3203 if (dtp
->u
.p
.mode
== READING
)
3205 /* Reset the endfile flag; if we hit EOF during reading
3206 we'll set the flag and generate an error at that point
3207 rather than worrying about it here. */
3208 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
3211 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
3213 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3214 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
3216 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3219 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
3224 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3225 "POS=specifier not allowed, "
3226 "Try OPEN with ACCESS='stream'");
3232 /* Sanity checks on the record number. */
3233 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
3237 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3238 "Record number must be positive");
3242 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
3244 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3245 "Record number too large");
3249 /* Make sure format buffer is reset. */
3250 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3251 fbuf_reset (dtp
->u
.p
.current_unit
);
3254 /* Check whether the record exists to be read. Only
3255 a partial record needs to exist. */
3257 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
3258 * dtp
->u
.p
.current_unit
->recl
>= ssize (dtp
->u
.p
.current_unit
->s
))
3260 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3261 "Non-existing record number");
3265 /* Position the file. */
3266 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
3267 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
3269 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3273 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
3275 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3276 "Record number not allowed for stream access "
3282 /* Bugware for badly written mixed C-Fortran I/O. */
3283 if (!is_internal_unit (dtp
))
3284 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
3286 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
3288 /* Set the maximum position reached from the previous I/O operation. This
3289 could be greater than zero from a previous non-advancing write. */
3290 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
3294 /* Make sure that we don't do a read after a nonadvancing write. */
3298 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
3300 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3301 "Cannot READ after a nonadvancing WRITE");
3307 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
3308 dtp
->u
.p
.current_unit
->read_bad
= 1;
3311 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3313 #ifdef HAVE_USELOCALE
3314 dtp
->u
.p
.old_locale
= uselocale (c_locale
);
3316 __gthread_mutex_lock (&old_locale_lock
);
3317 if (!old_locale_ctr
++)
3319 old_locale
= setlocale (LC_NUMERIC
, NULL
);
3320 setlocale (LC_NUMERIC
, "C");
3322 __gthread_mutex_unlock (&old_locale_lock
);
3324 /* Start the data transfer if we are doing a formatted transfer. */
3325 if ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0
3326 && dtp
->u
.p
.ionml
== NULL
)
3327 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
3332 /* Initialize an array_loop_spec given the array descriptor. The function
3333 returns the index of the last element of the array, and also returns
3334 starting record, where the first I/O goes to (necessary in case of
3335 negative strides). */
3338 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
3339 gfc_offset
*start_record
)
3341 int rank
= GFC_DESCRIPTOR_RANK(desc
);
3350 for (i
=0; i
<rank
; i
++)
3352 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3353 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3354 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
3355 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
3356 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
3357 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
3359 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
3361 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3362 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3366 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3367 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3368 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3369 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3379 /* Determine the index to the next record in an internal unit array by
3380 by incrementing through the array_loop_spec. */
3383 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
3391 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
3396 if (ls
[i
].idx
> ls
[i
].end
)
3398 ls
[i
].idx
= ls
[i
].start
;
3404 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
3414 /* Skip to the end of the current record, taking care of an optional
3415 record marker of size bytes. If the file is not seekable, we
3416 read chunks of size MAX_READ until we get to the right
3420 skip_record (st_parameter_dt
*dtp
, gfc_offset bytes
)
3422 ssize_t rlength
, readb
;
3423 #define MAX_READ 4096
3426 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
3427 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
3430 /* Direct access files do not generate END conditions,
3432 if (sseek (dtp
->u
.p
.current_unit
->s
,
3433 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
3435 /* Seeking failed, fall back to seeking by reading data. */
3436 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
3439 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
3440 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3442 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
3445 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3449 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
3453 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= 0;
3457 /* Advance to the next record reading unformatted files, taking
3458 care of subrecords. If complete_record is nonzero, we loop
3459 until all subrecords are cleared. */
3462 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
3466 bytes
= compile_options
.record_marker
== 0 ?
3467 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
3472 /* Skip over tail */
3474 skip_record (dtp
, bytes
);
3476 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
3485 min_off (gfc_offset a
, gfc_offset b
)
3487 return (a
< b
? a
: b
);
3491 /* Space to the next record for read mode. */
3494 next_record_r (st_parameter_dt
*dtp
, int done
)
3500 switch (current_mode (dtp
))
3502 /* No records in unformatted STREAM I/O. */
3503 case UNFORMATTED_STREAM
:
3506 case UNFORMATTED_SEQUENTIAL
:
3507 next_record_r_unf (dtp
, 1);
3508 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3511 case FORMATTED_DIRECT
:
3512 case UNFORMATTED_DIRECT
:
3513 skip_record (dtp
, dtp
->u
.p
.current_unit
->bytes_left
);
3516 case FORMATTED_STREAM
:
3517 case FORMATTED_SEQUENTIAL
:
3518 /* read_sf has already terminated input because of an '\n', or
3520 if (dtp
->u
.p
.sf_seen_eor
)
3522 dtp
->u
.p
.sf_seen_eor
= 0;
3526 if (is_internal_unit (dtp
))
3528 if (is_array_io (dtp
))
3532 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3534 if (!done
&& finished
)
3537 /* Now seek to this record. */
3538 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3539 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3541 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3544 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3548 gfc_offset bytes_left
= dtp
->u
.p
.current_unit
->bytes_left
;
3549 bytes_left
= min_off (bytes_left
,
3550 ssize (dtp
->u
.p
.current_unit
->s
)
3551 - stell (dtp
->u
.p
.current_unit
->s
));
3552 if (sseek (dtp
->u
.p
.current_unit
->s
,
3553 bytes_left
, SEEK_CUR
) < 0)
3555 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3558 dtp
->u
.p
.current_unit
->bytes_left
3559 = dtp
->u
.p
.current_unit
->recl
;
3563 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
3568 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
3572 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3575 if (is_stream_io (dtp
)
3576 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
3577 || dtp
->u
.p
.current_unit
->bytes_left
3578 == dtp
->u
.p
.current_unit
->recl
)
3584 if (is_stream_io (dtp
))
3585 dtp
->u
.p
.current_unit
->strm_pos
++;
3596 /* Small utility function to write a record marker, taking care of
3597 byte swapping and of choosing the correct size. */
3600 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
3606 if (compile_options
.record_marker
== 0)
3607 len
= sizeof (GFC_INTEGER_4
);
3609 len
= compile_options
.record_marker
;
3611 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
3612 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
3616 case sizeof (GFC_INTEGER_4
):
3618 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
3621 case sizeof (GFC_INTEGER_8
):
3623 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
3627 runtime_error ("Illegal value for record marker");
3637 case sizeof (GFC_INTEGER_4
):
3639 memcpy (&u32
, &buf4
, sizeof (u32
));
3640 u32
= __builtin_bswap32 (u32
);
3641 return swrite (dtp
->u
.p
.current_unit
->s
, &u32
, len
);
3644 case sizeof (GFC_INTEGER_8
):
3646 memcpy (&u64
, &buf8
, sizeof (u64
));
3647 u64
= __builtin_bswap64 (u64
);
3648 return swrite (dtp
->u
.p
.current_unit
->s
, &u64
, len
);
3652 runtime_error ("Illegal value for record marker");
3659 /* Position to the next (sub)record in write mode for
3660 unformatted sequential files. */
3663 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
3665 gfc_offset m
, m_write
, record_marker
;
3667 /* Bytes written. */
3668 m
= dtp
->u
.p
.current_unit
->recl_subrecord
3669 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3671 if (compile_options
.record_marker
== 0)
3672 record_marker
= sizeof (GFC_INTEGER_4
);
3674 record_marker
= compile_options
.record_marker
;
3676 /* Seek to the head and overwrite the bogus length with the real
3679 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- record_marker
,
3688 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3691 /* Seek past the end of the current record. */
3693 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
, SEEK_CUR
) < 0))
3696 /* Write the length tail. If we finish a record containing
3697 subrecords, we write out the negative length. */
3699 if (dtp
->u
.p
.current_unit
->continued
)
3704 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3710 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3716 /* Utility function like memset() but operating on streams. Return
3717 value is same as for POSIX write(). */
3720 sset (stream
*s
, int c
, gfc_offset nbyte
)
3722 #define WRITE_CHUNK 256
3723 char p
[WRITE_CHUNK
];
3724 gfc_offset bytes_left
;
3727 if (nbyte
< WRITE_CHUNK
)
3728 memset (p
, c
, nbyte
);
3730 memset (p
, c
, WRITE_CHUNK
);
3733 while (bytes_left
> 0)
3735 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
3736 trans
= swrite (s
, p
, trans
);
3739 bytes_left
-= trans
;
3742 return nbyte
- bytes_left
;
3746 /* Finish up a record according to the legacy carriagecontrol type, based
3747 on the first character in the record. */
3750 next_record_cc (st_parameter_dt
*dtp
)
3752 /* Only valid with CARRIAGECONTROL=FORTRAN. */
3753 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
3756 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3757 if (dtp
->u
.p
.cc
.len
> 0)
3759 char *p
= fbuf_alloc (dtp
->u
.p
.current_unit
, dtp
->u
.p
.cc
.len
);
3761 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3763 /* Output CR for the first character with default CC setting. */
3764 *(p
++) = dtp
->u
.p
.cc
.u
.end
;
3765 if (dtp
->u
.p
.cc
.len
> 1)
3766 *p
= dtp
->u
.p
.cc
.u
.end
;
3770 /* Position to the next record in write mode. */
3773 next_record_w (st_parameter_dt
*dtp
, int done
)
3775 gfc_offset max_pos_off
;
3777 /* Zero counters for X- and T-editing. */
3778 max_pos_off
= dtp
->u
.p
.max_pos
;
3779 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
3781 switch (current_mode (dtp
))
3783 /* No records in unformatted STREAM I/O. */
3784 case UNFORMATTED_STREAM
:
3787 case FORMATTED_DIRECT
:
3788 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
3791 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3792 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
3793 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
3794 dtp
->u
.p
.current_unit
->bytes_left
)
3795 != dtp
->u
.p
.current_unit
->bytes_left
)
3800 case UNFORMATTED_DIRECT
:
3801 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
3803 gfc_offset length
= dtp
->u
.p
.current_unit
->bytes_left
;
3804 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3809 case UNFORMATTED_SEQUENTIAL
:
3810 next_record_w_unf (dtp
, 0);
3811 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3814 case FORMATTED_STREAM
:
3815 case FORMATTED_SEQUENTIAL
:
3817 if (is_internal_unit (dtp
))
3820 /* Internal unit, so must fit in memory. */
3822 size_t max_pos
= max_pos_off
;
3823 if (is_array_io (dtp
))
3827 length
= dtp
->u
.p
.current_unit
->bytes_left
;
3829 /* If the farthest position reached is greater than current
3830 position, adjust the position and set length to pad out
3831 whats left. Otherwise just pad whats left.
3832 (for character array unit) */
3833 m
= dtp
->u
.p
.current_unit
->recl
3834 - dtp
->u
.p
.current_unit
->bytes_left
;
3837 length
= (max_pos
- m
);
3838 if (sseek (dtp
->u
.p
.current_unit
->s
,
3839 length
, SEEK_CUR
) < 0)
3841 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3844 length
= ((size_t) dtp
->u
.p
.current_unit
->recl
- max_pos
);
3847 p
= write_block (dtp
, length
);
3851 if (unlikely (is_char4_unit (dtp
)))
3853 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3854 memset4 (p4
, ' ', length
);
3857 memset (p
, ' ', length
);
3859 /* Now that the current record has been padded out,
3860 determine where the next record in the array is.
3861 Note that this can return a negative value, so it
3862 needs to be assigned to a signed value. */
3863 gfc_offset record
= next_array_record
3864 (dtp
, dtp
->u
.p
.current_unit
->ls
, &finished
);
3866 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3868 /* Now seek to this record */
3869 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3871 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3873 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3877 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3883 /* If this is the last call to next_record move to the farthest
3884 position reached and set length to pad out the remainder
3885 of the record. (for character scaler unit) */
3888 m
= dtp
->u
.p
.current_unit
->recl
3889 - dtp
->u
.p
.current_unit
->bytes_left
;
3892 length
= max_pos
- m
;
3893 if (sseek (dtp
->u
.p
.current_unit
->s
,
3894 length
, SEEK_CUR
) < 0)
3896 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3899 length
= (size_t) dtp
->u
.p
.current_unit
->recl
3903 length
= dtp
->u
.p
.current_unit
->bytes_left
;
3907 p
= write_block (dtp
, length
);
3911 if (unlikely (is_char4_unit (dtp
)))
3913 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3914 memset4 (p4
, (gfc_char4_t
) ' ', length
);
3917 memset (p
, ' ', length
);
3921 /* Handle legacy CARRIAGECONTROL line endings. */
3922 else if (dtp
->u
.p
.current_unit
->flags
.cc
== CC_FORTRAN
)
3923 next_record_cc (dtp
);
3926 /* Skip newlines for CC=CC_NONE. */
3927 const int len
= (dtp
->u
.p
.current_unit
->flags
.cc
== CC_NONE
)
3934 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3935 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
3937 char *p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3945 if (is_stream_io (dtp
))
3947 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3948 if (dtp
->u
.p
.current_unit
->strm_pos
3949 < ssize (dtp
->u
.p
.current_unit
->s
))
3950 unit_truncate (dtp
->u
.p
.current_unit
,
3951 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3959 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3964 /* Position to the next record, which means moving to the end of the
3965 current record. This can happen under several different
3966 conditions. If the done flag is not set, we get ready to process
3970 next_record (st_parameter_dt
*dtp
, int done
)
3972 gfc_offset fp
; /* File position. */
3974 dtp
->u
.p
.current_unit
->read_bad
= 0;
3976 if (dtp
->u
.p
.mode
== READING
)
3977 next_record_r (dtp
, done
);
3979 next_record_w (dtp
, done
);
3981 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3983 if (!is_stream_io (dtp
))
3985 /* Since we have changed the position, set it to unspecified so
3986 that INQUIRE(POSITION=) knows it needs to look into it. */
3988 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_UNSPECIFIED
;
3990 dtp
->u
.p
.current_unit
->current_record
= 0;
3991 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3993 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3994 /* Calculate next record, rounding up partial records. */
3995 dtp
->u
.p
.current_unit
->last_record
=
3996 (fp
+ dtp
->u
.p
.current_unit
->recl
) /
3997 dtp
->u
.p
.current_unit
->recl
- 1;
4000 dtp
->u
.p
.current_unit
->last_record
++;
4006 smarkeor (dtp
->u
.p
.current_unit
->s
);
4010 /* Finalize the current data transfer. For a nonadvancing transfer,
4011 this means advancing to the next record. For internal units close the
4012 stream associated with the unit. */
4015 finalize_transfer (st_parameter_dt
*dtp
)
4017 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
4019 if ((dtp
->u
.p
.ionml
!= NULL
)
4020 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
4022 dtp
->u
.p
.namelist_mode
= 1;
4023 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
4024 namelist_read (dtp
);
4026 namelist_write (dtp
);
4029 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
4030 *dtp
->size
= dtp
->u
.p
.current_unit
->size_used
;
4032 if (dtp
->u
.p
.eor_condition
)
4034 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
4038 if (dtp
->u
.p
.current_unit
&& (dtp
->u
.p
.current_unit
->child_dtio
> 0))
4040 if (cf
& IOPARM_DT_HAS_FORMAT
)
4042 free (dtp
->u
.p
.fmt
);
4048 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
4050 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
4051 dtp
->u
.p
.current_unit
->current_record
= 0;
4055 dtp
->u
.p
.transfer
= NULL
;
4056 if (dtp
->u
.p
.current_unit
== NULL
)
4059 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
4061 finish_list_read (dtp
);
4065 if (dtp
->u
.p
.mode
== WRITING
)
4066 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
4067 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
4069 if (is_stream_io (dtp
))
4071 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
4072 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
4073 next_record (dtp
, 1);
4078 dtp
->u
.p
.current_unit
->current_record
= 0;
4080 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
4082 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
4083 dtp
->u
.p
.seen_dollar
= 0;
4087 /* For non-advancing I/O, save the current maximum position for use in the
4088 next I/O operation if needed. */
4089 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
4091 if (dtp
->u
.p
.skips
> 0)
4094 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
4095 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
4096 - dtp
->u
.p
.current_unit
->bytes_left
);
4098 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
4101 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
4102 - dtp
->u
.p
.current_unit
->bytes_left
);
4103 dtp
->u
.p
.current_unit
->saved_pos
=
4104 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
4105 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
4108 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
4109 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
4110 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
4112 dtp
->u
.p
.current_unit
->saved_pos
= 0;
4113 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
4114 next_record (dtp
, 1);
4118 if (dtp
->u
.p
.unit_is_internal
)
4120 /* The unit structure may be reused later so clear the
4121 internal unit kind. */
4122 dtp
->u
.p
.current_unit
->internal_unit_kind
= 0;
4124 fbuf_destroy (dtp
->u
.p
.current_unit
);
4125 if (dtp
->u
.p
.current_unit
4126 && (dtp
->u
.p
.current_unit
->child_dtio
== 0)
4127 && dtp
->u
.p
.current_unit
->s
)
4129 sclose (dtp
->u
.p
.current_unit
->s
);
4130 dtp
->u
.p
.current_unit
->s
= NULL
;
4134 #ifdef HAVE_USELOCALE
4135 if (dtp
->u
.p
.old_locale
!= (locale_t
) 0)
4137 uselocale (dtp
->u
.p
.old_locale
);
4138 dtp
->u
.p
.old_locale
= (locale_t
) 0;
4141 __gthread_mutex_lock (&old_locale_lock
);
4142 if (!--old_locale_ctr
)
4144 setlocale (LC_NUMERIC
, old_locale
);
4147 __gthread_mutex_unlock (&old_locale_lock
);
4151 /* Transfer function for IOLENGTH. It doesn't actually do any
4152 data transfer, it just updates the length counter. */
4155 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
4156 void *dest
__attribute__ ((unused
)),
4157 int kind
__attribute__((unused
)),
4158 size_t size
, size_t nelems
)
4160 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
4161 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
4165 /* Initialize the IOLENGTH data transfer. This function is in essence
4166 a very much simplified version of data_transfer_init(), because it
4167 doesn't have to deal with units at all. */
4170 iolength_transfer_init (st_parameter_dt
*dtp
)
4172 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
4175 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
4177 /* Set up the subroutine that will handle the transfers. */
4179 dtp
->u
.p
.transfer
= iolength_transfer
;
4183 /* Library entry point for the IOLENGTH form of the INQUIRE
4184 statement. The IOLENGTH form requires no I/O to be performed, but
4185 it must still be a runtime library call so that we can determine
4186 the iolength for dynamic arrays and such. */
4188 extern void st_iolength (st_parameter_dt
*);
4189 export_proto(st_iolength
);
4192 st_iolength (st_parameter_dt
*dtp
)
4194 library_start (&dtp
->common
);
4195 iolength_transfer_init (dtp
);
4198 extern void st_iolength_done (st_parameter_dt
*);
4199 export_proto(st_iolength_done
);
4202 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
4209 /* The READ statement. */
4211 extern void st_read (st_parameter_dt
*);
4212 export_proto(st_read
);
4215 st_read (st_parameter_dt
*dtp
)
4217 library_start (&dtp
->common
);
4219 data_transfer_init (dtp
, 1);
4222 extern void st_read_done (st_parameter_dt
*);
4223 export_proto(st_read_done
);
4226 st_read_done_worker (st_parameter_dt
*dtp
)
4228 finalize_transfer (dtp
);
4232 /* If this is a parent READ statement we do not need to retain the
4233 internal unit structure for child use. */
4234 if (dtp
->u
.p
.current_unit
!= NULL
4235 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4237 if (dtp
->u
.p
.unit_is_internal
)
4239 if ((dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4241 free (dtp
->u
.p
.current_unit
->filename
);
4242 dtp
->u
.p
.current_unit
->filename
= NULL
;
4243 if (dtp
->u
.p
.current_unit
->ls
)
4244 free (dtp
->u
.p
.current_unit
->ls
);
4245 dtp
->u
.p
.current_unit
->ls
= NULL
;
4247 newunit_free (dtp
->common
.unit
);
4249 if (dtp
->u
.p
.unit_is_internal
|| dtp
->u
.p
.format_not_saved
)
4251 free_format_data (dtp
->u
.p
.fmt
);
4258 st_read_done (st_parameter_dt
*dtp
)
4260 if (dtp
->u
.p
.current_unit
)
4262 if (dtp
->u
.p
.current_unit
->au
)
4264 if (dtp
->common
.flags
& IOPARM_DT_HAS_ID
)
4265 *dtp
->id
= enqueue_done_id (dtp
->u
.p
.current_unit
->au
, AIO_READ_DONE
);
4268 enqueue_done (dtp
->u
.p
.current_unit
->au
, AIO_READ_DONE
);
4269 /* An asynchronous unit without ASYNCHRONOUS="YES" - make this
4270 synchronous by performing a wait operation. */
4271 if (!dtp
->u
.p
.async
)
4272 async_wait (&dtp
->common
, dtp
->u
.p
.current_unit
->au
);
4276 st_read_done_worker (dtp
);
4278 unlock_unit (dtp
->u
.p
.current_unit
);
4284 extern void st_write (st_parameter_dt
*);
4285 export_proto (st_write
);
4288 st_write (st_parameter_dt
*dtp
)
4290 library_start (&dtp
->common
);
4291 data_transfer_init (dtp
, 0);
4296 st_write_done_worker (st_parameter_dt
*dtp
)
4298 finalize_transfer (dtp
);
4300 if (dtp
->u
.p
.current_unit
!= NULL
4301 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4303 /* Deal with endfile conditions associated with sequential files. */
4304 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4305 switch (dtp
->u
.p
.current_unit
->endfile
)
4307 case AT_ENDFILE
: /* Remain at the endfile record. */
4311 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
4315 /* Get rid of whatever is after this record. */
4316 if (!is_internal_unit (dtp
))
4317 unit_truncate (dtp
->u
.p
.current_unit
,
4318 stell (dtp
->u
.p
.current_unit
->s
),
4320 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4326 /* If this is a parent WRITE statement we do not need to retain the
4327 internal unit structure for child use. */
4328 if (dtp
->u
.p
.unit_is_internal
)
4330 if ((dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4332 free (dtp
->u
.p
.current_unit
->filename
);
4333 dtp
->u
.p
.current_unit
->filename
= NULL
;
4334 if (dtp
->u
.p
.current_unit
->ls
)
4335 free (dtp
->u
.p
.current_unit
->ls
);
4336 dtp
->u
.p
.current_unit
->ls
= NULL
;
4338 newunit_free (dtp
->common
.unit
);
4340 if (dtp
->u
.p
.unit_is_internal
|| dtp
->u
.p
.format_not_saved
)
4342 free_format_data (dtp
->u
.p
.fmt
);
4348 extern void st_write_done (st_parameter_dt
*);
4349 export_proto(st_write_done
);
4352 st_write_done (st_parameter_dt
*dtp
)
4354 if (dtp
->u
.p
.current_unit
)
4356 if (dtp
->u
.p
.current_unit
->au
)
4358 if (dtp
->common
.flags
& IOPARM_DT_HAS_ID
)
4359 *dtp
->id
= enqueue_done_id (dtp
->u
.p
.current_unit
->au
,
4363 enqueue_done (dtp
->u
.p
.current_unit
->au
, AIO_WRITE_DONE
);
4364 /* An asynchronous unit without ASYNCHRONOUS="YES" - make this
4365 synchronous by performing a wait operation. */
4366 if (!dtp
->u
.p
.async
)
4367 async_wait (&dtp
->common
, dtp
->u
.p
.current_unit
->au
);
4371 st_write_done_worker (dtp
);
4373 unlock_unit (dtp
->u
.p
.current_unit
);
4379 /* Wait operation. We need to keep around the do-nothing version
4380 of st_wait for compatibility with previous versions, which had marked
4381 the argument as unused (and thus liable to be removed).
4383 TODO: remove at next bump in version number. */
4386 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
4392 st_wait_async (st_parameter_wait
*wtp
)
4394 gfc_unit
*u
= find_unit (wtp
->common
.unit
);
4395 if (ASYNC_IO
&& u
->au
)
4397 if (wtp
->common
.flags
& IOPARM_WAIT_HAS_ID
)
4398 async_wait_id (&(wtp
->common
), u
->au
, *wtp
->id
);
4400 async_wait (&(wtp
->common
), u
->au
);
4407 /* Receives the scalar information for namelist objects and stores it
4408 in a linked list of namelist_info types. */
4411 set_nml_var (st_parameter_dt
*dtp
, void *var_addr
, char *var_name
,
4412 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4413 dtype_type dtype
, void *dtio_sub
, void *vtable
)
4415 namelist_info
*t1
= NULL
;
4417 size_t var_name_len
= strlen (var_name
);
4419 nml
= (namelist_info
*) xmalloc (sizeof (namelist_info
));
4421 nml
->mem_pos
= var_addr
;
4422 nml
->dtio_sub
= dtio_sub
;
4423 nml
->vtable
= vtable
;
4425 nml
->var_name
= (char*) xmalloc (var_name_len
+ 1);
4426 memcpy (nml
->var_name
, var_name
, var_name_len
);
4427 nml
->var_name
[var_name_len
] = '\0';
4429 nml
->len
= (int) len
;
4430 nml
->string_length
= (index_type
) string_length
;
4432 nml
->var_rank
= (int) (dtype
.rank
);
4433 nml
->size
= (index_type
) (dtype
.elem_len
);
4434 nml
->type
= (bt
) (dtype
.type
);
4436 if (nml
->var_rank
> 0)
4438 nml
->dim
= (descriptor_dimension
*)
4439 xmallocarray (nml
->var_rank
, sizeof (descriptor_dimension
));
4440 nml
->ls
= (array_loop_spec
*)
4441 xmallocarray (nml
->var_rank
, sizeof (array_loop_spec
));
4451 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
4453 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
4454 dtp
->u
.p
.ionml
= nml
;
4458 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
4463 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
4464 GFC_INTEGER_4
, gfc_charlen_type
, dtype_type
);
4465 export_proto(st_set_nml_var
);
4468 st_set_nml_var (st_parameter_dt
*dtp
, void *var_addr
, char *var_name
,
4469 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4472 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4477 /* Essentially the same as previous but carrying the dtio procedure
4478 and the vtable as additional arguments. */
4479 extern void st_set_nml_dtio_var (st_parameter_dt
*dtp
, void *, char *,
4480 GFC_INTEGER_4
, gfc_charlen_type
, dtype_type
,
4482 export_proto(st_set_nml_dtio_var
);
4486 st_set_nml_dtio_var (st_parameter_dt
*dtp
, void *var_addr
, char *var_name
,
4487 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4488 dtype_type dtype
, void *dtio_sub
, void *vtable
)
4490 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4491 dtype
, dtio_sub
, vtable
);
4494 /* Store the dimensional information for the namelist object. */
4495 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
4496 index_type
, index_type
,
4498 export_proto(st_set_nml_var_dim
);
4501 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
4502 index_type stride
, index_type lbound
,
4510 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
4512 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
4516 /* Once upon a time, a poor innocent Fortran program was reading a
4517 file, when suddenly it hit the end-of-file (EOF). Unfortunately
4518 the OS doesn't tell whether we're at the EOF or whether we already
4519 went past it. Luckily our hero, libgfortran, keeps track of this.
4520 Call this function when you detect an EOF condition. See Section
4524 hit_eof (st_parameter_dt
*dtp
)
4526 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
4528 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4529 switch (dtp
->u
.p
.current_unit
->endfile
)
4533 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4534 if (!is_internal_unit (dtp
) && !dtp
->u
.p
.namelist_mode
)
4536 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
4537 dtp
->u
.p
.current_unit
->current_record
= 0;
4540 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4544 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
4545 dtp
->u
.p
.current_unit
->current_record
= 0;
4550 /* Non-sequential files don't have an ENDFILE record, so we
4551 can't be at AFTER_ENDFILE. */
4552 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4553 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4554 dtp
->u
.p
.current_unit
->current_record
= 0;