1 /* Copyright (C) 2002-2020 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
,
197 UNFORMATTED_STREAM
, FORMATTED_UNSPECIFIED
203 current_mode (st_parameter_dt
*dtp
)
207 m
= FORMATTED_UNSPECIFIED
;
209 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
211 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
212 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
214 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
216 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
217 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
219 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
221 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
222 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
229 /* Mid level data transfer statements. */
231 /* Read sequential file - internal unit */
234 read_sf_internal (st_parameter_dt
*dtp
, size_t *length
)
236 static char *empty_string
[0];
240 /* Zero size array gives internal unit len of 0. Nothing to read. */
241 if (dtp
->internal_unit_len
== 0
242 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
245 /* There are some cases with mixed DTIO where we have read a character
246 and saved it in the last character buffer, so we need to backup. */
247 if (unlikely (dtp
->u
.p
.current_unit
->child_dtio
> 0 &&
248 dtp
->u
.p
.current_unit
->last_char
!= EOF
- 1))
250 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
251 sseek (dtp
->u
.p
.current_unit
->s
, -1, SEEK_CUR
);
254 /* To support legacy code we have to scan the input string one byte
255 at a time because we don't know where an early comma may be and the
256 requested length could go past the end of a comma shortened
257 string. We only do this if -std=legacy was given at compile
258 time. We also do not support this on kind=4 strings. */
259 if (unlikely(compile_options
.warn_std
== 0)) // the slow legacy way.
265 /* If we have seen an eor previously, return a length of 0. The
266 caller is responsible for correctly padding the input field. */
267 if (dtp
->u
.p
.sf_seen_eor
)
270 /* Just return something that isn't a NULL pointer, otherwise the
271 caller thinks an error occurred. */
272 return (char*) empty_string
;
275 /* Get the first character of the string to establish the base
276 address and check for comma or end-of-record condition. */
277 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, &tmp
);
280 dtp
->u
.p
.sf_seen_eor
= 1;
282 return (char*) empty_string
;
286 dtp
->u
.p
.current_unit
->bytes_left
--;
288 return (char*) empty_string
;
291 /* Now we scan the rest and deal with either an end-of-file
292 condition or a comma, as needed. */
293 for (n
= 1; n
< *length
; n
++)
295 q
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, &tmp
);
303 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
312 if (is_char4_unit(dtp
))
314 gfc_char4_t
*p
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
,
316 base
= fbuf_alloc (dtp
->u
.p
.current_unit
, lorig
);
317 for (size_t i
= 0; i
< *length
; i
++, p
++)
318 base
[i
] = *p
> 255 ? '?' : (unsigned char) *p
;
321 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
323 if (unlikely (lorig
> *length
))
330 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
332 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
333 dtp
->u
.p
.current_unit
->has_size
)
334 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *length
;
340 /* When reading sequential formatted records we have a problem. We
341 don't know how long the line is until we read the trailing newline,
342 and we don't want to read too much. If we read too much, we might
343 have to do a physical seek backwards depending on how much data is
344 present, and devices like terminals aren't seekable and would cause
347 Given this, the solution is to read a byte at a time, stopping if
348 we hit the newline. For small allocations, we use a static buffer.
349 For larger allocations, we are forced to allocate memory on the
350 heap. Hopefully this won't happen very often. */
352 /* Read sequential file - external unit */
355 read_sf (st_parameter_dt
*dtp
, size_t *length
)
357 static char *empty_string
[0];
362 /* If we have seen an eor previously, return a length of 0. The
363 caller is responsible for correctly padding the input field. */
364 if (dtp
->u
.p
.sf_seen_eor
)
367 /* Just return something that isn't a NULL pointer, otherwise the
368 caller thinks an error occurred. */
369 return (char*) empty_string
;
372 /* There are some cases with mixed DTIO where we have read a character
373 and saved it in the last character buffer, so we need to backup. */
374 if (unlikely (dtp
->u
.p
.current_unit
->child_dtio
> 0 &&
375 dtp
->u
.p
.current_unit
->last_char
!= EOF
- 1))
377 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
378 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
383 /* Read data into format buffer and scan through it. */
388 q
= fbuf_getc (dtp
->u
.p
.current_unit
);
391 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
392 && (q
== '\n' || q
== '\r'))
394 /* Unexpected end of line. Set the position. */
395 dtp
->u
.p
.sf_seen_eor
= 1;
397 /* If we see an EOR during non-advancing I/O, we need to skip
398 the rest of the I/O statement. Set the corresponding flag. */
399 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
400 dtp
->u
.p
.eor_condition
= 1;
402 /* If we encounter a CR, it might be a CRLF. */
403 if (q
== '\r') /* Probably a CRLF */
405 /* See if there is an LF. */
406 q2
= fbuf_getc (dtp
->u
.p
.current_unit
);
408 dtp
->u
.p
.sf_seen_eor
= 2;
409 else if (q2
!= EOF
) /* Oops, seek back. */
410 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
413 /* Without padding, terminate the I/O statement without assigning
414 the value. With padding, the value still needs to be assigned,
415 so we can just continue with a short read. */
416 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
418 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
425 /* Short circuit the read if a comma is found during numeric input.
426 The flag is set to zero during character reads so that commas in
427 strings are not ignored */
429 if (dtp
->u
.p
.sf_read_comma
== 1)
432 notify_std (&dtp
->common
, GFC_STD_GNU
,
433 "Comma in formatted numeric read.");
441 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
442 some other stuff. Set the relevant flags. */
443 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
447 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
449 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
455 dtp
->u
.p
.eor_condition
= 1;
460 else if (dtp
->u
.p
.advance_status
== ADVANCE_NO
461 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
462 || dtp
->u
.p
.current_unit
->bytes_left
463 == dtp
->u
.p
.current_unit
->recl
)
472 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
474 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
475 dtp
->u
.p
.current_unit
->has_size
)
476 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) n
;
478 /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
479 fbuf_getc might reallocate the buffer. So return current pointer
480 minus all the advances, which is n plus up to two characters
481 of newline or comma. */
482 return fbuf_getptr (dtp
->u
.p
.current_unit
)
483 - n
- dtp
->u
.p
.sf_seen_eor
- seen_comma
;
487 /* Function for reading the next couple of bytes from the current
488 file, advancing the current position. We return NULL on end of record or
489 end of file. This function is only for formatted I/O, unformatted uses
492 If the read is short, then it is because the current record does not
493 have enough data to satisfy the read request and the file was
494 opened with PAD=YES. The caller must assume tailing spaces for
498 read_block_form (st_parameter_dt
*dtp
, size_t *nbytes
)
503 if (!is_stream_io (dtp
))
505 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
507 /* For preconnected units with default record length, set bytes left
508 to unit record length and proceed, otherwise error. */
509 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
510 && dtp
->u
.p
.current_unit
->recl
== default_recl
)
511 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
514 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
515 && !is_internal_unit (dtp
))
517 /* Not enough data left. */
518 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
523 if (is_internal_unit(dtp
))
525 if (*nbytes
> 0 && dtp
->u
.p
.current_unit
->bytes_left
== 0)
527 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
529 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
536 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0))
543 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
547 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
548 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
549 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
551 if (is_internal_unit (dtp
))
552 source
= read_sf_internal (dtp
, nbytes
);
554 source
= read_sf (dtp
, nbytes
);
556 dtp
->u
.p
.current_unit
->strm_pos
+=
557 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
561 /* If we reach here, we can assume it's direct access. */
563 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
566 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
567 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
569 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
570 dtp
->u
.p
.current_unit
->has_size
)
571 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *nbytes
;
573 if (norig
!= *nbytes
)
575 /* Short read, this shouldn't happen. */
576 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
578 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
583 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
589 /* Read a block from a character(kind=4) internal unit, to be transferred into
590 a character(kind=4) variable. Note: Portions of this code borrowed from
593 read_block_form4 (st_parameter_dt
*dtp
, size_t *nbytes
)
595 static gfc_char4_t
*empty_string
[0];
599 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
600 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
602 /* Zero size array gives internal unit len of 0. Nothing to read. */
603 if (dtp
->internal_unit_len
== 0
604 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
607 /* If we have seen an eor previously, return a length of 0. The
608 caller is responsible for correctly padding the input field. */
609 if (dtp
->u
.p
.sf_seen_eor
)
612 /* Just return something that isn't a NULL pointer, otherwise the
613 caller thinks an error occurred. */
618 source
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
, nbytes
);
620 if (unlikely (lorig
> *nbytes
))
626 dtp
->u
.p
.current_unit
->bytes_left
-= *nbytes
;
628 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
629 dtp
->u
.p
.current_unit
->has_size
)
630 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *nbytes
;
636 /* Reads a block directly into application data space. This is for
637 unformatted files. */
640 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
642 ssize_t to_read_record
;
643 ssize_t have_read_record
;
644 ssize_t to_read_subrecord
;
645 ssize_t have_read_subrecord
;
648 if (is_stream_io (dtp
))
650 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
652 if (unlikely (have_read_record
< 0))
654 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
658 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
660 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
662 /* Short read, e.g. if we hit EOF. For stream files,
663 we have to set the end-of-file condition. */
669 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
671 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
674 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
675 nbytes
= to_read_record
;
680 to_read_record
= nbytes
;
683 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
685 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
686 if (unlikely (to_read_record
< 0))
688 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
692 if (to_read_record
!= (ssize_t
) nbytes
)
694 /* Short read, e.g. if we hit EOF. Apparently, we read
695 more than was written to the last record. */
699 if (unlikely (short_record
))
701 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
706 /* Unformatted sequential. We loop over the subrecords, reading
707 until the request has been fulfilled or the record has run out
708 of continuation subrecords. */
710 /* Check whether we exceed the total record length. */
712 if (dtp
->u
.p
.current_unit
->flags
.has_recl
713 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
715 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
720 to_read_record
= nbytes
;
723 have_read_record
= 0;
727 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
728 < (gfc_offset
) to_read_record
)
730 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
731 to_read_record
-= to_read_subrecord
;
735 to_read_subrecord
= to_read_record
;
739 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
741 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
742 buf
+ have_read_record
, to_read_subrecord
);
743 if (unlikely (have_read_subrecord
< 0))
745 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
749 have_read_record
+= have_read_subrecord
;
751 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
753 /* Short read, e.g. if we hit EOF. This means the record
754 structure has been corrupted, or the trailing record
755 marker would still be present. */
757 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
761 if (to_read_record
> 0)
763 if (likely (dtp
->u
.p
.current_unit
->continued
))
765 next_record_r_unf (dtp
, 0);
770 /* Let's make sure the file position is correctly pre-positioned
771 for the next read statement. */
773 dtp
->u
.p
.current_unit
->current_record
= 0;
774 next_record_r_unf (dtp
, 0);
775 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
781 /* Normal exit, the read request has been fulfilled. */
786 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
787 if (unlikely (short_record
))
789 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
796 /* Function for writing a block of bytes to the current file at the
797 current position, advancing the file pointer. We are given a length
798 and return a pointer to a buffer that the caller must (completely)
799 fill in. Returns NULL on error. */
802 write_block (st_parameter_dt
*dtp
, size_t length
)
806 if (!is_stream_io (dtp
))
808 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
810 /* For preconnected units with default record length, set bytes left
811 to unit record length and proceed, otherwise error. */
812 if (likely ((dtp
->u
.p
.current_unit
->unit_number
813 == options
.stdout_unit
814 || dtp
->u
.p
.current_unit
->unit_number
815 == options
.stderr_unit
)
816 && dtp
->u
.p
.current_unit
->recl
== default_recl
))
817 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
820 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
825 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
828 if (is_internal_unit (dtp
))
830 if (is_char4_unit(dtp
)) /* char4 internel unit. */
833 dest4
= mem_alloc_w4 (dtp
->u
.p
.current_unit
->s
, &length
);
836 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
842 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
846 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
850 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
851 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
855 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
858 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
863 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
864 dtp
->u
.p
.current_unit
->has_size
)
865 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) length
;
867 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
873 /* High level interface to swrite(), taking care of errors. This is only
874 called for unformatted files. There are three cases to consider:
875 Stream I/O, unformatted direct, unformatted sequential. */
878 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
881 ssize_t have_written
;
882 ssize_t to_write_subrecord
;
887 if (is_stream_io (dtp
))
889 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
890 if (unlikely (have_written
< 0))
892 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
896 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
901 /* Unformatted direct access. */
903 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
905 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
907 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
911 if (buf
== NULL
&& nbytes
== 0)
914 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
915 if (unlikely (have_written
< 0))
917 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
921 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
922 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
927 /* Unformatted sequential. */
931 if (dtp
->u
.p
.current_unit
->flags
.has_recl
932 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
934 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
946 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
947 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
949 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
950 (gfc_offset
) to_write_subrecord
;
952 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
953 buf
+ have_written
, to_write_subrecord
);
954 if (unlikely (to_write_subrecord
< 0))
956 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
960 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
961 nbytes
-= to_write_subrecord
;
962 have_written
+= to_write_subrecord
;
967 next_record_w_unf (dtp
, 1);
970 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
971 if (unlikely (short_record
))
973 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
980 /* Reverse memcpy - used for byte swapping. */
983 reverse_memcpy (void *dest
, const void *src
, size_t n
)
989 s
= (char *) src
+ n
- 1;
991 /* Write with ascending order - this is likely faster
992 on modern architectures because of write combining. */
998 /* Utility function for byteswapping an array, using the bswap
999 builtins if possible. dest and src can overlap completely, or then
1000 they must point to separate objects; partial overlaps are not
1004 bswap_array (void *dest
, const void *src
, size_t size
, size_t nelems
)
1014 for (size_t i
= 0; i
< nelems
; i
++)
1015 ((uint16_t*)dest
)[i
] = __builtin_bswap16 (((uint16_t*)src
)[i
]);
1018 for (size_t i
= 0; i
< nelems
; i
++)
1019 ((uint32_t*)dest
)[i
] = __builtin_bswap32 (((uint32_t*)src
)[i
]);
1022 for (size_t i
= 0; i
< nelems
; i
++)
1023 ((uint64_t*)dest
)[i
] = __builtin_bswap64 (((uint64_t*)src
)[i
]);
1028 for (size_t i
= 0; i
< nelems
; i
++)
1031 memcpy (&tmp
, ps
, 4);
1032 *(uint32_t*)pd
= __builtin_bswap32 (*(uint32_t*)(ps
+ 8));
1033 *(uint32_t*)(pd
+ 4) = __builtin_bswap32 (*(uint32_t*)(ps
+ 4));
1034 *(uint32_t*)(pd
+ 8) = __builtin_bswap32 (tmp
);
1042 for (size_t i
= 0; i
< nelems
; i
++)
1045 memcpy (&tmp
, ps
, 8);
1046 *(uint64_t*)pd
= __builtin_bswap64 (*(uint64_t*)(ps
+ 8));
1047 *(uint64_t*)(pd
+ 8) = __builtin_bswap64 (tmp
);
1057 for (size_t i
= 0; i
< nelems
; i
++)
1059 reverse_memcpy (pd
, ps
, size
);
1066 /* In-place byte swap. */
1067 for (size_t i
= 0; i
< nelems
; i
++)
1069 char tmp
, *low
= pd
, *high
= pd
+ size
- 1;
1070 for (size_t j
= 0; j
< size
/2; j
++)
1085 /* Master function for unformatted reads. */
1088 unformatted_read (st_parameter_dt
*dtp
, bt type
,
1089 void *dest
, int kind
, size_t size
, size_t nelems
)
1091 if (type
== BT_CLASS
)
1093 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1094 char tmp_iomsg
[IOMSG_LEN
] = "";
1096 gfc_charlen_type child_iomsg_len
;
1098 int *child_iostat
= NULL
;
1100 /* Set iostat, intent(out). */
1102 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1103 dtp
->common
.iostat
: &noiostat
;
1105 /* Set iomsg, intent(inout). */
1106 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1108 child_iomsg
= dtp
->common
.iomsg
;
1109 child_iomsg_len
= dtp
->common
.iomsg_len
;
1113 child_iomsg
= tmp_iomsg
;
1114 child_iomsg_len
= IOMSG_LEN
;
1117 /* Call the user defined unformatted READ procedure. */
1118 dtp
->u
.p
.current_unit
->child_dtio
++;
1119 dtp
->u
.p
.ufdtio_ptr (dest
, &unit
, child_iostat
, child_iomsg
,
1121 dtp
->u
.p
.current_unit
->child_dtio
--;
1125 if (type
== BT_CHARACTER
)
1126 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
1127 read_block_direct (dtp
, dest
, size
* nelems
);
1129 if (unlikely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_SWAP
)
1132 /* Handle wide chracters. */
1133 if (type
== BT_CHARACTER
)
1139 /* Break up complex into its constituent reals. */
1140 else if (type
== BT_COMPLEX
)
1145 bswap_array (dest
, dest
, size
, nelems
);
1150 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
1151 bytes on 64 bit machines. The unused bytes are not initialized and never
1152 used, which can show an error with memory checking analyzers like
1153 valgrind. We us BT_CLASS to denote a User Defined I/O call. */
1156 unformatted_write (st_parameter_dt
*dtp
, bt type
,
1157 void *source
, int kind
, size_t size
, size_t nelems
)
1159 if (type
== BT_CLASS
)
1161 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1162 char tmp_iomsg
[IOMSG_LEN
] = "";
1164 gfc_charlen_type child_iomsg_len
;
1166 int *child_iostat
= NULL
;
1168 /* Set iostat, intent(out). */
1170 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1171 dtp
->common
.iostat
: &noiostat
;
1173 /* Set iomsg, intent(inout). */
1174 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1176 child_iomsg
= dtp
->common
.iomsg
;
1177 child_iomsg_len
= dtp
->common
.iomsg_len
;
1181 child_iomsg
= tmp_iomsg
;
1182 child_iomsg_len
= IOMSG_LEN
;
1185 /* Call the user defined unformatted WRITE procedure. */
1186 dtp
->u
.p
.current_unit
->child_dtio
++;
1187 dtp
->u
.p
.ufdtio_ptr (source
, &unit
, child_iostat
, child_iomsg
,
1189 dtp
->u
.p
.current_unit
->child_dtio
--;
1193 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1196 size_t stride
= type
== BT_CHARACTER
?
1197 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1199 write_buf (dtp
, source
, stride
* nelems
);
1203 #define BSWAP_BUFSZ 512
1204 char buffer
[BSWAP_BUFSZ
];
1210 /* Handle wide chracters. */
1211 if (type
== BT_CHARACTER
&& kind
!= 1)
1217 /* Break up complex into its constituent reals. */
1218 if (type
== BT_COMPLEX
)
1224 /* By now, all complex variables have been split into their
1225 constituent reals. */
1231 if (size
* nrem
> BSWAP_BUFSZ
)
1232 nc
= BSWAP_BUFSZ
/ size
;
1236 bswap_array (buffer
, p
, size
, nc
);
1237 write_buf (dtp
, buffer
, size
* nc
);
1246 /* Return a pointer to the name of a type. */
1271 p
= "CLASS or DERIVED";
1274 internal_error (NULL
, "type_name(): Bad type");
1281 /* Write a constant string to the output.
1282 This is complicated because the string can have doubled delimiters
1283 in it. The length in the format node is the true length. */
1286 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
1288 char c
, delimiter
, *p
, *q
;
1291 length
= f
->u
.string
.length
;
1295 p
= write_block (dtp
, length
);
1302 for (; length
> 0; length
--)
1305 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
1306 q
++; /* Skip the doubled delimiter. */
1311 /* Given actual and expected types in a formatted data transfer, make
1312 sure they agree. If not, an error message is generated. Returns
1313 nonzero if something went wrong. */
1316 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
1319 char buffer
[BUFLEN
];
1321 if (actual
== expected
)
1324 /* Adjust item_count before emitting error message. */
1325 snprintf (buffer
, BUFLEN
,
1326 "Expected %s for item %d in formatted transfer, got %s",
1327 type_name (expected
), dtp
->u
.p
.item_count
- 1, type_name (actual
));
1329 format_error (dtp
, f
, buffer
);
1334 /* Check that the dtio procedure required for formatted IO is present. */
1337 check_dtio_proc (st_parameter_dt
*dtp
, const fnode
*f
)
1339 char buffer
[BUFLEN
];
1341 if (dtp
->u
.p
.fdtio_ptr
!= NULL
)
1344 snprintf (buffer
, BUFLEN
,
1345 "Missing DTIO procedure or intrinsic type passed for item %d "
1346 "in formatted transfer",
1347 dtp
->u
.p
.item_count
- 1);
1349 format_error (dtp
, f
, buffer
);
1355 require_numeric_type (st_parameter_dt
*dtp
, bt actual
, const fnode
*f
)
1358 char buffer
[BUFLEN
];
1360 if (actual
== BT_INTEGER
|| actual
== BT_REAL
|| actual
== BT_COMPLEX
)
1363 /* Adjust item_count before emitting error message. */
1364 snprintf (buffer
, BUFLEN
,
1365 "Expected numeric type for item %d in formatted transfer, got %s",
1366 dtp
->u
.p
.item_count
- 1, type_name (actual
));
1368 format_error (dtp
, f
, buffer
);
1373 get_dt_format (char *p
, gfc_charlen_type
*length
)
1375 char delim
= p
[-1]; /* The delimiter is always the first character back. */
1377 gfc_charlen_type len
= *length
; /* This length already correct, less 'DT'. */
1379 res
= q
= xmalloc (len
+ 2);
1381 /* Set the beginning of the string to 'DT', length adjusted below. */
1385 /* The string may contain doubled quotes so scan and skip as needed. */
1386 for (; len
> 0; len
--)
1390 p
++; /* Skip the doubled delimiter. */
1393 /* Adjust the string length by two now that we are done. */
1400 /* This function is in the main loop for a formatted data transfer
1401 statement. It would be natural to implement this as a coroutine
1402 with the user program, but C makes that awkward. We loop,
1403 processing format elements. When we actually have to transfer
1404 data instead of just setting flags, we return control to the user
1405 program which calls a function that supplies the address and type
1406 of the next element, then comes back here to process it. */
1409 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1412 int pos
, bytes_used
;
1416 int consume_data_flag
;
1418 /* Change a complex data item into a pair of reals. */
1420 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1421 if (type
== BT_COMPLEX
)
1427 /* If there's an EOR condition, we simulate finalizing the transfer
1428 by doing nothing. */
1429 if (dtp
->u
.p
.eor_condition
)
1432 /* Set this flag so that commas in reads cause the read to complete before
1433 the entire field has been read. The next read field will start right after
1434 the comma in the stream. (Set to 0 for character reads). */
1435 dtp
->u
.p
.sf_read_comma
=
1436 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1440 /* If reversion has occurred and there is another real data item,
1441 then we have to move to the next record. */
1442 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1444 dtp
->u
.p
.reversion_flag
= 0;
1445 next_record (dtp
, 0);
1448 consume_data_flag
= 1;
1449 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1452 f
= next_format (dtp
);
1455 /* No data descriptors left. */
1456 if (unlikely (n
> 0))
1457 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1458 "Insufficient data descriptors in format after reversion");
1464 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1465 - dtp
->u
.p
.current_unit
->bytes_left
);
1467 if (is_stream_io(dtp
))
1474 goto need_read_data
;
1475 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1477 read_decimal (dtp
, f
, p
, kind
);
1482 goto need_read_data
;
1483 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1484 && require_numeric_type (dtp
, type
, f
))
1486 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1487 && require_type (dtp
, BT_INTEGER
, type
, f
))
1489 read_radix (dtp
, f
, p
, kind
, 2);
1494 goto need_read_data
;
1495 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1496 && require_numeric_type (dtp
, type
, f
))
1498 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1499 && require_type (dtp
, BT_INTEGER
, type
, f
))
1501 read_radix (dtp
, f
, p
, kind
, 8);
1506 goto need_read_data
;
1507 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1508 && require_numeric_type (dtp
, type
, f
))
1510 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1511 && require_type (dtp
, BT_INTEGER
, type
, f
))
1513 read_radix (dtp
, f
, p
, kind
, 16);
1518 goto need_read_data
;
1520 /* It is possible to have FMT_A with something not BT_CHARACTER such
1521 as when writing out hollerith strings, so check both type
1522 and kind before calling wide character routines. */
1523 if (type
== BT_CHARACTER
&& kind
== 4)
1524 read_a_char4 (dtp
, f
, p
, size
);
1526 read_a (dtp
, f
, p
, size
);
1531 goto need_read_data
;
1532 read_l (dtp
, f
, p
, kind
);
1537 goto need_read_data
;
1538 if (require_type (dtp
, BT_REAL
, type
, f
))
1540 read_f (dtp
, f
, p
, kind
);
1545 goto need_read_data
;
1547 if (check_dtio_proc (dtp
, f
))
1549 if (require_type (dtp
, BT_CLASS
, type
, f
))
1551 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1553 char tmp_iomsg
[IOMSG_LEN
] = "";
1555 gfc_charlen_type child_iomsg_len
;
1557 int *child_iostat
= NULL
;
1559 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1561 /* Build the iotype string. */
1562 if (iotype_len
== 0)
1568 iotype
= get_dt_format (f
->u
.udf
.string
, &iotype_len
);
1570 /* Set iostat, intent(out). */
1572 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1573 dtp
->common
.iostat
: &noiostat
;
1575 /* Set iomsg, intent(inout). */
1576 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1578 child_iomsg
= dtp
->common
.iomsg
;
1579 child_iomsg_len
= dtp
->common
.iomsg_len
;
1583 child_iomsg
= tmp_iomsg
;
1584 child_iomsg_len
= IOMSG_LEN
;
1587 /* Call the user defined formatted READ procedure. */
1588 dtp
->u
.p
.current_unit
->child_dtio
++;
1589 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
1590 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1591 child_iostat
, child_iomsg
,
1592 iotype_len
, child_iomsg_len
);
1593 dtp
->u
.p
.current_unit
->child_dtio
--;
1595 if (f
->u
.udf
.string_len
!= 0)
1597 /* Note: vlist is freed in free_format_data. */
1602 goto need_read_data
;
1603 if (require_type (dtp
, BT_REAL
, type
, f
))
1605 read_f (dtp
, f
, p
, kind
);
1610 goto need_read_data
;
1611 if (require_type (dtp
, BT_REAL
, type
, f
))
1613 read_f (dtp
, f
, p
, kind
);
1618 goto need_read_data
;
1619 if (require_type (dtp
, BT_REAL
, type
, f
))
1621 read_f (dtp
, f
, p
, kind
);
1626 goto need_read_data
;
1627 if (require_type (dtp
, BT_REAL
, type
, f
))
1629 read_f (dtp
, f
, p
, kind
);
1634 goto need_read_data
;
1638 read_decimal (dtp
, f
, p
, kind
);
1641 read_l (dtp
, f
, p
, kind
);
1645 read_a_char4 (dtp
, f
, p
, size
);
1647 read_a (dtp
, f
, p
, size
);
1650 read_f (dtp
, f
, p
, kind
);
1653 internal_error (&dtp
->common
,
1654 "formatted_transfer (): Bad type");
1659 consume_data_flag
= 0;
1660 format_error (dtp
, f
, "Constant string in input format");
1663 /* Format codes that don't transfer data. */
1666 consume_data_flag
= 0;
1667 dtp
->u
.p
.skips
+= f
->u
.n
;
1668 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1669 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1670 read_x (dtp
, f
->u
.n
);
1675 consume_data_flag
= 0;
1677 if (f
->format
== FMT_TL
)
1679 /* Handle the special case when no bytes have been used yet.
1680 Cannot go below zero. */
1681 if (bytes_used
== 0)
1683 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1684 dtp
->u
.p
.skips
-= f
->u
.n
;
1685 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1688 pos
= bytes_used
- f
->u
.n
;
1693 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1694 left tab limit. We do not check if the position has gone
1695 beyond the end of record because a subsequent tab could
1696 bring us back again. */
1697 pos
= pos
< 0 ? 0 : pos
;
1699 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1700 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1701 + pos
- dtp
->u
.p
.max_pos
;
1702 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1703 ? 0 : dtp
->u
.p
.pending_spaces
;
1704 if (dtp
->u
.p
.skips
== 0)
1707 /* Adjust everything for end-of-record condition */
1708 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1710 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1711 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1713 if (dtp
->u
.p
.pending_spaces
== 0)
1714 dtp
->u
.p
.sf_seen_eor
= 0;
1716 if (dtp
->u
.p
.skips
< 0)
1718 if (is_internal_unit (dtp
))
1719 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1721 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1722 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1723 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1726 read_x (dtp
, dtp
->u
.p
.skips
);
1730 consume_data_flag
= 0;
1731 dtp
->u
.p
.sign_status
= SIGN_PROCDEFINED
;
1735 consume_data_flag
= 0;
1736 dtp
->u
.p
.sign_status
= SIGN_SUPPRESS
;
1740 consume_data_flag
= 0;
1741 dtp
->u
.p
.sign_status
= SIGN_PLUS
;
1745 consume_data_flag
= 0 ;
1746 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1750 consume_data_flag
= 0;
1751 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1755 consume_data_flag
= 0;
1756 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1760 consume_data_flag
= 0;
1761 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1765 consume_data_flag
= 0;
1766 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1770 consume_data_flag
= 0;
1771 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1775 consume_data_flag
= 0;
1776 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1780 consume_data_flag
= 0;
1781 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1785 consume_data_flag
= 0;
1786 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1790 consume_data_flag
= 0;
1791 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1795 consume_data_flag
= 0;
1796 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1800 consume_data_flag
= 0;
1801 dtp
->u
.p
.seen_dollar
= 1;
1805 consume_data_flag
= 0;
1806 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1807 next_record (dtp
, 0);
1811 /* A colon descriptor causes us to exit this loop (in
1812 particular preventing another / descriptor from being
1813 processed) unless there is another data item to be
1815 consume_data_flag
= 0;
1821 internal_error (&dtp
->common
, "Bad format node");
1824 /* Adjust the item count and data pointer. */
1826 if ((consume_data_flag
> 0) && (n
> 0))
1829 p
= ((char *) p
) + size
;
1834 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1835 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1840 /* Come here when we need a data descriptor but don't have one. We
1841 push the current format node back onto the input, then return and
1842 let the user program call us back with the data. */
1844 unget_format (dtp
, f
);
1849 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1852 gfc_offset pos
, bytes_used
;
1856 int consume_data_flag
;
1858 /* Change a complex data item into a pair of reals. */
1860 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1861 if (type
== BT_COMPLEX
)
1867 /* If there's an EOR condition, we simulate finalizing the transfer
1868 by doing nothing. */
1869 if (dtp
->u
.p
.eor_condition
)
1872 /* Set this flag so that commas in reads cause the read to complete before
1873 the entire field has been read. The next read field will start right after
1874 the comma in the stream. (Set to 0 for character reads). */
1875 dtp
->u
.p
.sf_read_comma
=
1876 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1880 /* If reversion has occurred and there is another real data item,
1881 then we have to move to the next record. */
1882 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1884 dtp
->u
.p
.reversion_flag
= 0;
1885 next_record (dtp
, 0);
1888 consume_data_flag
= 1;
1889 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1892 f
= next_format (dtp
);
1895 /* No data descriptors left. */
1896 if (unlikely (n
> 0))
1897 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1898 "Insufficient data descriptors in format after reversion");
1902 /* Now discharge T, TR and X movements to the right. This is delayed
1903 until a data producing format to suppress trailing spaces. */
1906 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1907 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1908 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1909 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1910 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
1912 || t
== FMT_STRING
))
1914 if (dtp
->u
.p
.skips
> 0)
1917 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1918 tmp
= dtp
->u
.p
.current_unit
->recl
1919 - dtp
->u
.p
.current_unit
->bytes_left
;
1921 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1924 if (dtp
->u
.p
.skips
< 0)
1926 if (is_internal_unit (dtp
))
1927 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1929 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1930 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1932 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1935 bytes_used
= dtp
->u
.p
.current_unit
->recl
1936 - dtp
->u
.p
.current_unit
->bytes_left
;
1938 if (is_stream_io(dtp
))
1946 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1948 write_i (dtp
, f
, p
, kind
);
1954 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1955 && require_numeric_type (dtp
, type
, f
))
1957 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1958 && require_type (dtp
, BT_INTEGER
, type
, f
))
1960 write_b (dtp
, f
, p
, kind
);
1966 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1967 && require_numeric_type (dtp
, type
, f
))
1969 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1970 && require_type (dtp
, BT_INTEGER
, type
, f
))
1972 write_o (dtp
, f
, p
, kind
);
1978 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1979 && require_numeric_type (dtp
, type
, f
))
1981 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1982 && require_type (dtp
, BT_INTEGER
, type
, f
))
1984 write_z (dtp
, f
, p
, kind
);
1991 /* It is possible to have FMT_A with something not BT_CHARACTER such
1992 as when writing out hollerith strings, so check both type
1993 and kind before calling wide character routines. */
1994 if (type
== BT_CHARACTER
&& kind
== 4)
1995 write_a_char4 (dtp
, f
, p
, size
);
1997 write_a (dtp
, f
, p
, size
);
2003 write_l (dtp
, f
, p
, kind
);
2009 if (require_type (dtp
, BT_REAL
, type
, f
))
2011 if (f
->u
.real
.w
== 0)
2012 write_real_w0 (dtp
, p
, kind
, f
);
2014 write_d (dtp
, f
, p
, kind
);
2020 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
2022 char tmp_iomsg
[IOMSG_LEN
] = "";
2024 gfc_charlen_type child_iomsg_len
;
2026 int *child_iostat
= NULL
;
2028 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
2030 /* Build the iotype string. */
2031 if (iotype_len
== 0)
2037 iotype
= get_dt_format (f
->u
.udf
.string
, &iotype_len
);
2039 /* Set iostat, intent(out). */
2041 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
2042 dtp
->common
.iostat
: &noiostat
;
2044 /* Set iomsg, intent(inout). */
2045 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
2047 child_iomsg
= dtp
->common
.iomsg
;
2048 child_iomsg_len
= dtp
->common
.iomsg_len
;
2052 child_iomsg
= tmp_iomsg
;
2053 child_iomsg_len
= IOMSG_LEN
;
2056 if (check_dtio_proc (dtp
, f
))
2059 /* Call the user defined formatted WRITE procedure. */
2060 dtp
->u
.p
.current_unit
->child_dtio
++;
2062 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
2063 child_iostat
, child_iomsg
,
2064 iotype_len
, child_iomsg_len
);
2065 dtp
->u
.p
.current_unit
->child_dtio
--;
2067 if (f
->u
.udf
.string_len
!= 0)
2069 /* Note: vlist is freed in free_format_data. */
2075 if (require_type (dtp
, BT_REAL
, type
, f
))
2077 if (f
->u
.real
.w
== 0)
2078 write_real_w0 (dtp
, p
, kind
, f
);
2080 write_e (dtp
, f
, p
, kind
);
2086 if (require_type (dtp
, BT_REAL
, type
, f
))
2088 if (f
->u
.real
.w
== 0)
2089 write_real_w0 (dtp
, p
, kind
, f
);
2091 write_en (dtp
, f
, p
, kind
);
2097 if (require_type (dtp
, BT_REAL
, type
, f
))
2099 if (f
->u
.real
.w
== 0)
2100 write_real_w0 (dtp
, p
, kind
, f
);
2102 write_es (dtp
, f
, p
, kind
);
2108 if (require_type (dtp
, BT_REAL
, type
, f
))
2110 write_f (dtp
, f
, p
, kind
);
2119 write_i (dtp
, f
, p
, kind
);
2122 write_l (dtp
, f
, p
, kind
);
2126 write_a_char4 (dtp
, f
, p
, size
);
2128 write_a (dtp
, f
, p
, size
);
2131 if (f
->u
.real
.w
== 0)
2132 write_real_w0 (dtp
, p
, kind
, f
);
2134 write_d (dtp
, f
, p
, kind
);
2137 internal_error (&dtp
->common
,
2138 "formatted_transfer (): Bad type");
2143 consume_data_flag
= 0;
2144 write_constant_string (dtp
, f
);
2147 /* Format codes that don't transfer data. */
2150 consume_data_flag
= 0;
2152 dtp
->u
.p
.skips
+= f
->u
.n
;
2153 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
2154 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
2155 /* Writes occur just before the switch on f->format, above, so
2156 that trailing blanks are suppressed, unless we are doing a
2157 non-advancing write in which case we want to output the blanks
2159 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2161 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
2162 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2168 consume_data_flag
= 0;
2170 if (f
->format
== FMT_TL
)
2173 /* Handle the special case when no bytes have been used yet.
2174 Cannot go below zero. */
2175 if (bytes_used
== 0)
2177 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
2178 dtp
->u
.p
.skips
-= f
->u
.n
;
2179 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
2182 pos
= bytes_used
- f
->u
.n
;
2185 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
2187 /* Standard 10.6.1.1: excessive left tabbing is reset to the
2188 left tab limit. We do not check if the position has gone
2189 beyond the end of record because a subsequent tab could
2190 bring us back again. */
2191 pos
= pos
< 0 ? 0 : pos
;
2193 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
2194 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
2195 + pos
- dtp
->u
.p
.max_pos
;
2196 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
2197 ? 0 : dtp
->u
.p
.pending_spaces
;
2201 consume_data_flag
= 0;
2202 dtp
->u
.p
.sign_status
= SIGN_PROCDEFINED
;
2206 consume_data_flag
= 0;
2207 dtp
->u
.p
.sign_status
= SIGN_SUPPRESS
;
2211 consume_data_flag
= 0;
2212 dtp
->u
.p
.sign_status
= SIGN_PLUS
;
2216 consume_data_flag
= 0 ;
2217 dtp
->u
.p
.blank_status
= BLANK_NULL
;
2221 consume_data_flag
= 0;
2222 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
2226 consume_data_flag
= 0;
2227 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
2231 consume_data_flag
= 0;
2232 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
2236 consume_data_flag
= 0;
2237 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
2241 consume_data_flag
= 0;
2242 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
2246 consume_data_flag
= 0;
2247 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
2251 consume_data_flag
= 0;
2252 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
2256 consume_data_flag
= 0;
2257 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
2261 consume_data_flag
= 0;
2262 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
2266 consume_data_flag
= 0;
2267 dtp
->u
.p
.scale_factor
= f
->u
.k
;
2271 consume_data_flag
= 0;
2272 dtp
->u
.p
.seen_dollar
= 1;
2276 consume_data_flag
= 0;
2277 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2278 next_record (dtp
, 0);
2282 /* A colon descriptor causes us to exit this loop (in
2283 particular preventing another / descriptor from being
2284 processed) unless there is another data item to be
2286 consume_data_flag
= 0;
2292 internal_error (&dtp
->common
, "Bad format node");
2295 /* Adjust the item count and data pointer. */
2297 if ((consume_data_flag
> 0) && (n
> 0))
2300 p
= ((char *) p
) + size
;
2303 pos
= dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
;
2304 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
2309 /* Come here when we need a data descriptor but don't have one. We
2310 push the current format node back onto the input, then return and
2311 let the user program call us back with the data. */
2313 unget_format (dtp
, f
);
2316 /* This function is first called from data_init_transfer to initiate the loop
2317 over each item in the format, transferring data as required. Subsequent
2318 calls to this function occur for each data item foound in the READ/WRITE
2319 statement. The item_count is incremented for each call. Since the first
2320 call is from data_transfer_init, the item_count is always one greater than
2321 the actual count number of the item being transferred. */
2324 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2325 size_t size
, size_t nelems
)
2331 size_t stride
= type
== BT_CHARACTER
?
2332 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2333 if (dtp
->u
.p
.mode
== READING
)
2335 /* Big loop over all the elements. */
2336 for (elem
= 0; elem
< nelems
; elem
++)
2338 dtp
->u
.p
.item_count
++;
2339 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2344 /* Big loop over all the elements. */
2345 for (elem
= 0; elem
< nelems
; elem
++)
2347 dtp
->u
.p
.item_count
++;
2348 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2353 /* Wrapper function for I/O of scalar types. If this should be an async I/O
2354 request, queue it. For a synchronous write on an async unit, perform the
2355 wait operation and return an error. For all synchronous writes, call the
2356 right transfer function. */
2359 wrap_scalar_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2360 size_t size
, size_t n_elem
)
2362 if (dtp
->u
.p
.current_unit
&& dtp
->u
.p
.current_unit
->au
)
2367 args
.scalar
.transfer
= dtp
->u
.p
.transfer
;
2368 args
.scalar
.arg_bt
= type
;
2369 args
.scalar
.data
= p
;
2370 args
.scalar
.i
= kind
;
2371 args
.scalar
.s1
= size
;
2372 args
.scalar
.s2
= n_elem
;
2373 enqueue_transfer (dtp
->u
.p
.current_unit
->au
, &args
,
2374 AIO_TRANSFER_SCALAR
);
2378 /* Come here if there was no asynchronous I/O to be scheduled. */
2379 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2382 dtp
->u
.p
.transfer (dtp
, type
, p
, kind
, size
, 1);
2386 /* Data transfer entry points. The type of the data entity is
2387 implicit in the subroutine call. This prevents us from having to
2388 share a common enum with the compiler. */
2391 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
2393 wrap_scalar_transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
2397 transfer_integer_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2399 transfer_integer (dtp
, p
, kind
);
2403 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
2406 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2408 size
= size_from_real_kind (kind
);
2409 wrap_scalar_transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
2413 transfer_real_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2415 transfer_real (dtp
, p
, kind
);
2419 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
2421 wrap_scalar_transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
2425 transfer_logical_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2427 transfer_logical (dtp
, p
, kind
);
2431 transfer_character (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
)
2433 static char *empty_string
[0];
2435 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2438 /* Strings of zero length can have p == NULL, which confuses the
2439 transfer routines into thinking we need more data elements. To avoid
2440 this, we give them a nice pointer. */
2441 if (len
== 0 && p
== NULL
)
2444 /* Set kind here to 1. */
2445 wrap_scalar_transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
2449 transfer_character_write (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
)
2451 transfer_character (dtp
, p
, len
);
2455 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
, int kind
)
2457 static char *empty_string
[0];
2459 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2462 /* Strings of zero length can have p == NULL, which confuses the
2463 transfer routines into thinking we need more data elements. To avoid
2464 this, we give them a nice pointer. */
2465 if (len
== 0 && p
== NULL
)
2468 /* Here we pass the actual kind value. */
2469 wrap_scalar_transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
2473 transfer_character_wide_write (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
, int kind
)
2475 transfer_character_wide (dtp
, p
, len
, kind
);
2479 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
2482 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2484 size
= size_from_complex_kind (kind
);
2485 wrap_scalar_transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
2489 transfer_complex_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2491 transfer_complex (dtp
, p
, kind
);
2495 transfer_array_inner (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2496 gfc_charlen_type charlen
)
2498 index_type count
[GFC_MAX_DIMENSIONS
];
2499 index_type extent
[GFC_MAX_DIMENSIONS
];
2500 index_type stride
[GFC_MAX_DIMENSIONS
];
2501 index_type stride0
, rank
, size
, n
;
2506 /* Adjust item_count before emitting error message. */
2508 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2511 iotype
= (bt
) GFC_DESCRIPTOR_TYPE (desc
);
2512 size
= iotype
== BT_CHARACTER
? charlen
: GFC_DESCRIPTOR_SIZE (desc
);
2514 rank
= GFC_DESCRIPTOR_RANK (desc
);
2516 for (n
= 0; n
< rank
; n
++)
2519 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
2520 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
2522 /* If the extent of even one dimension is zero, then the entire
2523 array section contains zero elements, so we return after writing
2524 a zero array record. */
2529 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2534 stride0
= stride
[0];
2536 /* If the innermost dimension has a stride of 1, we can do the transfer
2537 in contiguous chunks. */
2538 if (stride0
== size
)
2543 data
= GFC_DESCRIPTOR_DATA (desc
);
2545 /* When reading, we need to check endfile conditions so we do not miss
2546 an END=label. Make this separate so we do not have an extra test
2547 in a tight loop when it is not needed. */
2549 if (dtp
->u
.p
.current_unit
&& dtp
->u
.p
.mode
== READING
)
2553 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
))
2556 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2557 data
+= stride0
* tsize
;
2560 while (count
[n
] == extent
[n
])
2563 data
-= stride
[n
] * extent
[n
];
2582 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2583 data
+= stride0
* tsize
;
2586 while (count
[n
] == extent
[n
])
2589 data
-= stride
[n
] * extent
[n
];
2607 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2608 gfc_charlen_type charlen
)
2610 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2613 if (dtp
->u
.p
.current_unit
&& dtp
->u
.p
.current_unit
->au
)
2618 size_t sz
= sizeof (gfc_array_char
)
2619 + sizeof (descriptor_dimension
)
2620 * GFC_DESCRIPTOR_RANK (desc
);
2621 args
.array
.desc
= xmalloc (sz
);
2622 NOTE ("desc = %p", (void *) args
.array
.desc
);
2623 memcpy (args
.array
.desc
, desc
, sz
);
2624 args
.array
.kind
= kind
;
2625 args
.array
.charlen
= charlen
;
2626 enqueue_transfer (dtp
->u
.p
.current_unit
->au
, &args
,
2627 AIO_TRANSFER_ARRAY
);
2631 /* Come here if there was no asynchronous I/O to be scheduled. */
2632 transfer_array_inner (dtp
, desc
, kind
, charlen
);
2637 transfer_array_write (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2638 gfc_charlen_type charlen
)
2640 transfer_array (dtp
, desc
, kind
, charlen
);
2644 /* User defined input/output iomsg. */
2646 #define IOMSG_LEN 256
2649 transfer_derived (st_parameter_dt
*parent
, void *dtio_source
, void *dtio_proc
)
2651 if (parent
->u
.p
.current_unit
)
2653 if (parent
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2654 parent
->u
.p
.ufdtio_ptr
= (unformatted_dtio
) dtio_proc
;
2656 parent
->u
.p
.fdtio_ptr
= (formatted_dtio
) dtio_proc
;
2658 wrap_scalar_transfer (parent
, BT_CLASS
, dtio_source
, 0, 0, 1);
2662 /* Preposition a sequential unformatted file while reading. */
2665 us_read (st_parameter_dt
*dtp
, int continued
)
2672 if (compile_options
.record_marker
== 0)
2673 n
= sizeof (GFC_INTEGER_4
);
2675 n
= compile_options
.record_marker
;
2677 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
2678 if (unlikely (nr
< 0))
2680 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2686 return; /* end of file */
2688 else if (unlikely (n
!= nr
))
2690 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2694 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2695 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2699 case sizeof(GFC_INTEGER_4
):
2700 memcpy (&i4
, &i
, sizeof (i4
));
2704 case sizeof(GFC_INTEGER_8
):
2705 memcpy (&i8
, &i
, sizeof (i8
));
2710 runtime_error ("Illegal value for record marker");
2720 case sizeof(GFC_INTEGER_4
):
2721 memcpy (&u32
, &i
, sizeof (u32
));
2722 u32
= __builtin_bswap32 (u32
);
2723 memcpy (&i4
, &u32
, sizeof (i4
));
2727 case sizeof(GFC_INTEGER_8
):
2728 memcpy (&u64
, &i
, sizeof (u64
));
2729 u64
= __builtin_bswap64 (u64
);
2730 memcpy (&i8
, &u64
, sizeof (i8
));
2735 runtime_error ("Illegal value for record marker");
2742 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
2743 dtp
->u
.p
.current_unit
->continued
= 0;
2747 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
2748 dtp
->u
.p
.current_unit
->continued
= 1;
2752 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2756 /* Preposition a sequential unformatted file while writing. This
2757 amount to writing a bogus length that will be filled in later. */
2760 us_write (st_parameter_dt
*dtp
, int continued
)
2767 if (compile_options
.record_marker
== 0)
2768 nbytes
= sizeof (GFC_INTEGER_4
);
2770 nbytes
= compile_options
.record_marker
;
2772 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2773 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2775 /* For sequential unformatted, if RECL= was not specified in the OPEN
2776 we write until we have more bytes than can fit in the subrecord
2777 markers, then we write a new subrecord. */
2779 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2780 dtp
->u
.p
.current_unit
->recl_subrecord
;
2781 dtp
->u
.p
.current_unit
->continued
= continued
;
2785 /* Position to the next record prior to transfer. We are assumed to
2786 be before the next record. We also calculate the bytes in the next
2790 pre_position (st_parameter_dt
*dtp
)
2792 if (dtp
->u
.p
.current_unit
->current_record
)
2793 return; /* Already positioned. */
2795 switch (current_mode (dtp
))
2797 case FORMATTED_STREAM
:
2798 case UNFORMATTED_STREAM
:
2799 /* There are no records with stream I/O. If the position was specified
2800 data_transfer_init has already positioned the file. If no position
2801 was specified, we continue from where we last left off. I.e.
2802 there is nothing to do here. */
2805 case UNFORMATTED_SEQUENTIAL
:
2806 if (dtp
->u
.p
.mode
== READING
)
2813 case FORMATTED_SEQUENTIAL
:
2814 case FORMATTED_DIRECT
:
2815 case UNFORMATTED_DIRECT
:
2816 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2818 case FORMATTED_UNSPECIFIED
:
2822 dtp
->u
.p
.current_unit
->current_record
= 1;
2826 /* Initialize things for a data transfer. This code is common for
2827 both reading and writing. */
2830 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2832 unit_flags u_flags
; /* Used for creating a unit if needed. */
2833 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2834 namelist_info
*ionml
;
2837 NOTE ("data_transfer_init");
2839 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2841 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2843 dtp
->u
.p
.ionml
= ionml
;
2844 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2845 dtp
->u
.p
.namelist_mode
= 0;
2846 dtp
->u
.p
.cc
.len
= 0;
2848 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2851 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2853 if (dtp
->u
.p
.current_unit
== NULL
)
2855 /* This means we tried to access an external unit < 0 without
2856 having opened it first with NEWUNIT=. */
2857 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2858 "Unit number is negative and unit was not already "
2859 "opened with OPEN(NEWUNIT=...)");
2862 else if (dtp
->u
.p
.current_unit
->s
== NULL
)
2863 { /* Open the unit with some default flags. */
2864 st_parameter_open opp
;
2866 NOTE ("Open the unit with some default flags.");
2867 memset (&u_flags
, '\0', sizeof (u_flags
));
2868 u_flags
.access
= ACCESS_SEQUENTIAL
;
2869 u_flags
.action
= ACTION_READWRITE
;
2871 /* Is it unformatted? */
2872 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2873 | IOPARM_DT_IONML_SET
)))
2874 u_flags
.form
= FORM_UNFORMATTED
;
2876 u_flags
.form
= FORM_UNSPECIFIED
;
2878 u_flags
.delim
= DELIM_UNSPECIFIED
;
2879 u_flags
.blank
= BLANK_UNSPECIFIED
;
2880 u_flags
.pad
= PAD_UNSPECIFIED
;
2881 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2882 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2883 u_flags
.async
= ASYNC_UNSPECIFIED
;
2884 u_flags
.round
= ROUND_UNSPECIFIED
;
2885 u_flags
.sign
= SIGN_UNSPECIFIED
;
2886 u_flags
.share
= SHARE_UNSPECIFIED
;
2887 u_flags
.cc
= CC_UNSPECIFIED
;
2888 u_flags
.readonly
= 0;
2890 u_flags
.status
= STATUS_UNKNOWN
;
2892 conv
= get_unformatted_convert (dtp
->common
.unit
);
2894 if (conv
== GFC_CONVERT_NONE
)
2895 conv
= compile_options
.convert
;
2899 case GFC_CONVERT_NATIVE
:
2900 case GFC_CONVERT_SWAP
:
2903 case GFC_CONVERT_BIG
:
2904 conv
= __BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2907 case GFC_CONVERT_LITTLE
:
2908 conv
= __BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2912 internal_error (&opp
.common
, "Illegal value for CONVERT");
2916 u_flags
.convert
= conv
;
2918 opp
.common
= dtp
->common
;
2919 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2920 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2921 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2922 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2923 if (dtp
->u
.p
.current_unit
== NULL
)
2927 if (dtp
->u
.p
.current_unit
->child_dtio
== 0)
2929 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2931 dtp
->u
.p
.current_unit
->has_size
= true;
2932 /* Initialize the count. */
2933 dtp
->u
.p
.current_unit
->size_used
= 0;
2936 dtp
->u
.p
.current_unit
->has_size
= false;
2938 else if (dtp
->u
.p
.current_unit
->internal_unit_kind
> 0)
2939 dtp
->u
.p
.unit_is_internal
= 1;
2941 if ((cf
& IOPARM_DT_HAS_ASYNCHRONOUS
) != 0)
2944 f
= find_option (&dtp
->common
, dtp
->asynchronous
, dtp
->asynchronous_len
,
2945 async_opt
, "Bad ASYNCHRONOUS in data transfer "
2947 if (f
== ASYNC_YES
&& dtp
->u
.p
.current_unit
->flags
.async
!= ASYNC_YES
)
2949 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2950 "ASYNCHRONOUS transfer without "
2951 "ASYHCRONOUS='YES' in OPEN");
2954 dtp
->u
.p
.async
= f
== ASYNC_YES
;
2957 au
= dtp
->u
.p
.current_unit
->au
;
2962 /* If this is an asynchronous I/O statement, collect errors and
2963 return if there are any. */
2964 if (collect_async_errors (&dtp
->common
, au
))
2969 /* Synchronous statement: Perform a wait operation for any pending
2970 asynchronous I/O. This needs to be done before all other error
2971 checks. See F2008, 9.6.4.1. */
2972 if (async_wait (&(dtp
->common
), au
))
2977 /* Check the action. */
2979 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2981 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2982 "Cannot read from file opened for WRITE");
2986 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2988 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2989 "Cannot write to file opened for READ");
2993 dtp
->u
.p
.first_item
= 1;
2995 /* Check the format. */
2997 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
3000 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
3001 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
3004 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3005 "Format present for UNFORMATTED data transfer");
3009 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
3011 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
3013 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3014 "A format cannot be specified with a namelist");
3018 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
3019 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
3021 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3022 "Missing format for FORMATTED data transfer");
3026 if (is_internal_unit (dtp
)
3027 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3029 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3030 "Internal file cannot be accessed by UNFORMATTED "
3035 /* Check the record or position number. */
3037 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
3038 && (cf
& IOPARM_DT_HAS_REC
) == 0)
3040 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
3041 "Direct access data transfer requires record number");
3045 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3047 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
3049 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3050 "Record number not allowed for sequential access "
3055 if (compile_options
.warn_std
&&
3056 dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
)
3058 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3059 "Sequential READ or WRITE not allowed after "
3060 "EOF marker, possibly use REWIND or BACKSPACE");
3065 /* Process the ADVANCE option. */
3067 dtp
->u
.p
.advance_status
3068 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
3069 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
3070 "Bad ADVANCE parameter in data transfer statement");
3072 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
3074 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3076 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3077 "ADVANCE specification conflicts with sequential "
3082 if (is_internal_unit (dtp
))
3084 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3085 "ADVANCE specification conflicts with internal file");
3089 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
3090 != IOPARM_DT_HAS_FORMAT
)
3092 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3093 "ADVANCE specification requires an explicit format");
3098 /* Child IO is non-advancing and any ADVANCE= specifier is ignored.
3100 if (dtp
->u
.p
.current_unit
->child_dtio
> 0)
3101 dtp
->u
.p
.advance_status
= ADVANCE_NO
;
3105 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
3107 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3109 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
3110 "EOR specification requires an ADVANCE specification "
3115 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
3116 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3118 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
3119 "SIZE specification requires an ADVANCE "
3120 "specification of NO");
3125 { /* Write constraints. */
3126 if ((cf
& IOPARM_END
) != 0)
3128 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3129 "END specification cannot appear in a write "
3134 if ((cf
& IOPARM_EOR
) != 0)
3136 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3137 "EOR specification cannot appear in a write "
3142 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
3144 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3145 "SIZE specification cannot appear in a write "
3151 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
3152 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
3154 /* Check the decimal mode. */
3155 dtp
->u
.p
.current_unit
->decimal_status
3156 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
3157 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
3158 decimal_opt
, "Bad DECIMAL parameter in data transfer "
3161 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
3162 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
3164 /* Check the round mode. */
3165 dtp
->u
.p
.current_unit
->round_status
3166 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
3167 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
3168 round_opt
, "Bad ROUND parameter in data transfer "
3171 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
3172 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
3174 /* Check the sign mode. */
3175 dtp
->u
.p
.sign_status
3176 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
3177 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
3178 "Bad SIGN parameter in data transfer statement");
3180 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
3181 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
3183 /* Check the blank mode. */
3184 dtp
->u
.p
.blank_status
3185 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
3186 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
3188 "Bad BLANK parameter in data transfer statement");
3190 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
3191 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
3193 /* Check the delim mode. */
3194 dtp
->u
.p
.current_unit
->delim_status
3195 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
3196 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
3197 delim_opt
, "Bad DELIM parameter in data transfer statement");
3199 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
3201 if (ionml
&& dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_UNSPECIFIED
)
3202 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
3204 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
3207 /* Check the pad mode. */
3208 dtp
->u
.p
.current_unit
->pad_status
3209 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
3210 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
3211 "Bad PAD parameter in data transfer statement");
3213 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
3214 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
3216 /* Set up the subroutine that will handle the transfers. */
3220 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3221 dtp
->u
.p
.transfer
= unformatted_read
;
3224 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3225 dtp
->u
.p
.transfer
= list_formatted_read
;
3227 dtp
->u
.p
.transfer
= formatted_transfer
;
3232 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3233 dtp
->u
.p
.transfer
= unformatted_write
;
3236 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3237 dtp
->u
.p
.transfer
= list_formatted_write
;
3239 dtp
->u
.p
.transfer
= formatted_transfer
;
3243 if (au
&& dtp
->u
.p
.async
)
3245 NOTE ("enqueue_data_transfer");
3246 enqueue_data_transfer_init (au
, dtp
, read_flag
);
3250 NOTE ("invoking data_transfer_init_worker");
3251 data_transfer_init_worker (dtp
, read_flag
);
3256 data_transfer_init_worker (st_parameter_dt
*dtp
, int read_flag
)
3258 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3260 NOTE ("starting worker...");
3262 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.form
!= FORM_UNFORMATTED
3263 && ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3264 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
3265 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
3267 /* Check to see if we might be reading what we wrote before */
3269 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
3270 && !is_internal_unit (dtp
))
3272 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
3274 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
3275 sflush(dtp
->u
.p
.current_unit
->s
);
3278 /* Check the POS= specifier: that it is in range and that it is used with a
3279 unit that has been connected for STREAM access. F2003 9.5.1.10. */
3281 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
3283 if (is_stream_io (dtp
))
3288 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3289 "POS=specifier must be positive");
3293 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
3295 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3296 "POS=specifier too large");
3300 dtp
->rec
= dtp
->pos
;
3302 if (dtp
->u
.p
.mode
== READING
)
3304 /* Reset the endfile flag; if we hit EOF during reading
3305 we'll set the flag and generate an error at that point
3306 rather than worrying about it here. */
3307 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
3310 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
3312 fbuf_reset (dtp
->u
.p
.current_unit
);
3313 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1,
3316 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3319 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
3324 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3325 "POS=specifier not allowed, "
3326 "Try OPEN with ACCESS='stream'");
3332 /* Sanity checks on the record number. */
3333 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
3337 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3338 "Record number must be positive");
3342 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
3344 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3345 "Record number too large");
3349 /* Make sure format buffer is reset. */
3350 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3351 fbuf_reset (dtp
->u
.p
.current_unit
);
3354 /* Check whether the record exists to be read. Only
3355 a partial record needs to exist. */
3357 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
3358 * dtp
->u
.p
.current_unit
->recl
>= ssize (dtp
->u
.p
.current_unit
->s
))
3360 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3361 "Non-existing record number");
3365 /* Position the file. */
3366 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
3367 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
3369 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3373 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
3375 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3376 "Record number not allowed for stream access "
3382 /* Bugware for badly written mixed C-Fortran I/O. */
3383 if (!is_internal_unit (dtp
))
3384 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
3386 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
3388 /* Set the maximum position reached from the previous I/O operation. This
3389 could be greater than zero from a previous non-advancing write. */
3390 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
3394 /* Make sure that we don't do a read after a nonadvancing write. */
3398 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
3400 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3401 "Cannot READ after a nonadvancing WRITE");
3407 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
3408 dtp
->u
.p
.current_unit
->read_bad
= 1;
3411 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3413 #ifdef HAVE_USELOCALE
3414 dtp
->u
.p
.old_locale
= uselocale (c_locale
);
3416 __gthread_mutex_lock (&old_locale_lock
);
3417 if (!old_locale_ctr
++)
3419 old_locale
= setlocale (LC_NUMERIC
, NULL
);
3420 setlocale (LC_NUMERIC
, "C");
3422 __gthread_mutex_unlock (&old_locale_lock
);
3424 /* Start the data transfer if we are doing a formatted transfer. */
3425 if ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0
3426 && dtp
->u
.p
.ionml
== NULL
)
3427 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
3432 /* Initialize an array_loop_spec given the array descriptor. The function
3433 returns the index of the last element of the array, and also returns
3434 starting record, where the first I/O goes to (necessary in case of
3435 negative strides). */
3438 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
3439 gfc_offset
*start_record
)
3441 int rank
= GFC_DESCRIPTOR_RANK(desc
);
3450 for (i
=0; i
<rank
; i
++)
3452 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3453 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3454 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
3455 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
3456 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
3457 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
3459 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
3461 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3462 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3466 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3467 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3468 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3469 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3479 /* Determine the index to the next record in an internal unit array by
3480 by incrementing through the array_loop_spec. */
3483 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
3491 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
3496 if (ls
[i
].idx
> ls
[i
].end
)
3498 ls
[i
].idx
= ls
[i
].start
;
3504 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
3514 /* Skip to the end of the current record, taking care of an optional
3515 record marker of size bytes. If the file is not seekable, we
3516 read chunks of size MAX_READ until we get to the right
3520 skip_record (st_parameter_dt
*dtp
, gfc_offset bytes
)
3522 ssize_t rlength
, readb
;
3523 #define MAX_READ 4096
3526 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
3527 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
3530 /* Direct access files do not generate END conditions,
3532 if (sseek (dtp
->u
.p
.current_unit
->s
,
3533 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
3535 /* Seeking failed, fall back to seeking by reading data. */
3536 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
3539 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
3540 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3542 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
3545 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3549 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
3553 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= 0;
3557 /* Advance to the next record reading unformatted files, taking
3558 care of subrecords. If complete_record is nonzero, we loop
3559 until all subrecords are cleared. */
3562 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
3566 bytes
= compile_options
.record_marker
== 0 ?
3567 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
3572 /* Skip over tail */
3574 skip_record (dtp
, bytes
);
3576 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
3585 min_off (gfc_offset a
, gfc_offset b
)
3587 return (a
< b
? a
: b
);
3591 /* Space to the next record for read mode. */
3594 next_record_r (st_parameter_dt
*dtp
, int done
)
3600 switch (current_mode (dtp
))
3602 /* No records in unformatted STREAM I/O. */
3603 case UNFORMATTED_STREAM
:
3606 case UNFORMATTED_SEQUENTIAL
:
3607 next_record_r_unf (dtp
, 1);
3608 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3611 case FORMATTED_DIRECT
:
3612 case UNFORMATTED_DIRECT
:
3613 skip_record (dtp
, dtp
->u
.p
.current_unit
->bytes_left
);
3616 case FORMATTED_STREAM
:
3617 case FORMATTED_SEQUENTIAL
:
3618 /* read_sf has already terminated input because of an '\n', or
3620 if (dtp
->u
.p
.sf_seen_eor
)
3622 dtp
->u
.p
.sf_seen_eor
= 0;
3626 if (is_internal_unit (dtp
))
3628 if (is_array_io (dtp
))
3632 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3634 if (!done
&& finished
)
3637 /* Now seek to this record. */
3638 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3639 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3641 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3644 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3648 gfc_offset bytes_left
= dtp
->u
.p
.current_unit
->bytes_left
;
3649 bytes_left
= min_off (bytes_left
,
3650 ssize (dtp
->u
.p
.current_unit
->s
)
3651 - stell (dtp
->u
.p
.current_unit
->s
));
3652 if (sseek (dtp
->u
.p
.current_unit
->s
,
3653 bytes_left
, SEEK_CUR
) < 0)
3655 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3658 dtp
->u
.p
.current_unit
->bytes_left
3659 = dtp
->u
.p
.current_unit
->recl
;
3663 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
3668 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
3672 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3675 if (is_stream_io (dtp
)
3676 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
3677 || dtp
->u
.p
.current_unit
->bytes_left
3678 == dtp
->u
.p
.current_unit
->recl
)
3684 if (is_stream_io (dtp
))
3685 dtp
->u
.p
.current_unit
->strm_pos
++;
3692 case FORMATTED_UNSPECIFIED
:
3698 /* Small utility function to write a record marker, taking care of
3699 byte swapping and of choosing the correct size. */
3702 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
3708 if (compile_options
.record_marker
== 0)
3709 len
= sizeof (GFC_INTEGER_4
);
3711 len
= compile_options
.record_marker
;
3713 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
3714 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
3718 case sizeof (GFC_INTEGER_4
):
3720 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
3723 case sizeof (GFC_INTEGER_8
):
3725 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
3729 runtime_error ("Illegal value for record marker");
3739 case sizeof (GFC_INTEGER_4
):
3741 memcpy (&u32
, &buf4
, sizeof (u32
));
3742 u32
= __builtin_bswap32 (u32
);
3743 return swrite (dtp
->u
.p
.current_unit
->s
, &u32
, len
);
3746 case sizeof (GFC_INTEGER_8
):
3748 memcpy (&u64
, &buf8
, sizeof (u64
));
3749 u64
= __builtin_bswap64 (u64
);
3750 return swrite (dtp
->u
.p
.current_unit
->s
, &u64
, len
);
3754 runtime_error ("Illegal value for record marker");
3761 /* Position to the next (sub)record in write mode for
3762 unformatted sequential files. */
3765 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
3767 gfc_offset m
, m_write
, record_marker
;
3769 /* Bytes written. */
3770 m
= dtp
->u
.p
.current_unit
->recl_subrecord
3771 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3773 if (compile_options
.record_marker
== 0)
3774 record_marker
= sizeof (GFC_INTEGER_4
);
3776 record_marker
= compile_options
.record_marker
;
3778 /* Seek to the head and overwrite the bogus length with the real
3781 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- record_marker
,
3790 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3793 /* Seek past the end of the current record. */
3795 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
, SEEK_CUR
) < 0))
3798 /* Write the length tail. If we finish a record containing
3799 subrecords, we write out the negative length. */
3801 if (dtp
->u
.p
.current_unit
->continued
)
3806 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3812 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3818 /* Utility function like memset() but operating on streams. Return
3819 value is same as for POSIX write(). */
3822 sset (stream
*s
, int c
, gfc_offset nbyte
)
3824 #define WRITE_CHUNK 256
3825 char p
[WRITE_CHUNK
];
3826 gfc_offset bytes_left
;
3829 if (nbyte
< WRITE_CHUNK
)
3830 memset (p
, c
, nbyte
);
3832 memset (p
, c
, WRITE_CHUNK
);
3835 while (bytes_left
> 0)
3837 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
3838 trans
= swrite (s
, p
, trans
);
3841 bytes_left
-= trans
;
3844 return nbyte
- bytes_left
;
3848 /* Finish up a record according to the legacy carriagecontrol type, based
3849 on the first character in the record. */
3852 next_record_cc (st_parameter_dt
*dtp
)
3854 /* Only valid with CARRIAGECONTROL=FORTRAN. */
3855 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
3858 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3859 if (dtp
->u
.p
.cc
.len
> 0)
3861 char *p
= fbuf_alloc (dtp
->u
.p
.current_unit
, dtp
->u
.p
.cc
.len
);
3863 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3865 /* Output CR for the first character with default CC setting. */
3866 *(p
++) = dtp
->u
.p
.cc
.u
.end
;
3867 if (dtp
->u
.p
.cc
.len
> 1)
3868 *p
= dtp
->u
.p
.cc
.u
.end
;
3872 /* Position to the next record in write mode. */
3875 next_record_w (st_parameter_dt
*dtp
, int done
)
3877 gfc_offset max_pos_off
;
3879 /* Zero counters for X- and T-editing. */
3880 max_pos_off
= dtp
->u
.p
.max_pos
;
3881 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
3883 switch (current_mode (dtp
))
3885 /* No records in unformatted STREAM I/O. */
3886 case UNFORMATTED_STREAM
:
3889 case FORMATTED_DIRECT
:
3890 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
3893 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3894 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
3895 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
3896 dtp
->u
.p
.current_unit
->bytes_left
)
3897 != dtp
->u
.p
.current_unit
->bytes_left
)
3902 case UNFORMATTED_DIRECT
:
3903 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
3905 gfc_offset length
= dtp
->u
.p
.current_unit
->bytes_left
;
3906 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3911 case UNFORMATTED_SEQUENTIAL
:
3912 next_record_w_unf (dtp
, 0);
3913 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3916 case FORMATTED_STREAM
:
3917 case FORMATTED_SEQUENTIAL
:
3919 if (is_internal_unit (dtp
))
3922 /* Internal unit, so must fit in memory. */
3924 size_t max_pos
= max_pos_off
;
3925 if (is_array_io (dtp
))
3929 length
= dtp
->u
.p
.current_unit
->bytes_left
;
3931 /* If the farthest position reached is greater than current
3932 position, adjust the position and set length to pad out
3933 whats left. Otherwise just pad whats left.
3934 (for character array unit) */
3935 m
= dtp
->u
.p
.current_unit
->recl
3936 - dtp
->u
.p
.current_unit
->bytes_left
;
3939 length
= (max_pos
- m
);
3940 if (sseek (dtp
->u
.p
.current_unit
->s
,
3941 length
, SEEK_CUR
) < 0)
3943 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3946 length
= ((size_t) dtp
->u
.p
.current_unit
->recl
- max_pos
);
3949 p
= write_block (dtp
, length
);
3953 if (unlikely (is_char4_unit (dtp
)))
3955 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3956 memset4 (p4
, ' ', length
);
3959 memset (p
, ' ', length
);
3961 /* Now that the current record has been padded out,
3962 determine where the next record in the array is.
3963 Note that this can return a negative value, so it
3964 needs to be assigned to a signed value. */
3965 gfc_offset record
= next_array_record
3966 (dtp
, dtp
->u
.p
.current_unit
->ls
, &finished
);
3968 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3970 /* Now seek to this record */
3971 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3973 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3975 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3979 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3985 /* If this is the last call to next_record move to the farthest
3986 position reached and set length to pad out the remainder
3987 of the record. (for character scaler unit) */
3990 m
= dtp
->u
.p
.current_unit
->recl
3991 - dtp
->u
.p
.current_unit
->bytes_left
;
3994 length
= max_pos
- m
;
3995 if (sseek (dtp
->u
.p
.current_unit
->s
,
3996 length
, SEEK_CUR
) < 0)
3998 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
4001 length
= (size_t) dtp
->u
.p
.current_unit
->recl
4005 length
= dtp
->u
.p
.current_unit
->bytes_left
;
4009 p
= write_block (dtp
, length
);
4013 if (unlikely (is_char4_unit (dtp
)))
4015 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
4016 memset4 (p4
, (gfc_char4_t
) ' ', length
);
4019 memset (p
, ' ', length
);
4023 /* Handle legacy CARRIAGECONTROL line endings. */
4024 else if (dtp
->u
.p
.current_unit
->flags
.cc
== CC_FORTRAN
)
4025 next_record_cc (dtp
);
4028 /* Skip newlines for CC=CC_NONE. */
4029 const int len
= (dtp
->u
.p
.current_unit
->flags
.cc
== CC_NONE
)
4036 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
4037 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
4039 char *p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
4047 if (is_stream_io (dtp
))
4049 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
4050 if (dtp
->u
.p
.current_unit
->strm_pos
4051 < ssize (dtp
->u
.p
.current_unit
->s
))
4052 unit_truncate (dtp
->u
.p
.current_unit
,
4053 dtp
->u
.p
.current_unit
->strm_pos
- 1,
4059 case FORMATTED_UNSPECIFIED
:
4063 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
4068 /* Position to the next record, which means moving to the end of the
4069 current record. This can happen under several different
4070 conditions. If the done flag is not set, we get ready to process
4074 next_record (st_parameter_dt
*dtp
, int done
)
4076 gfc_offset fp
; /* File position. */
4078 dtp
->u
.p
.current_unit
->read_bad
= 0;
4080 if (dtp
->u
.p
.mode
== READING
)
4081 next_record_r (dtp
, done
);
4083 next_record_w (dtp
, done
);
4085 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
4087 if (!is_stream_io (dtp
))
4089 /* Since we have changed the position, set it to unspecified so
4090 that INQUIRE(POSITION=) knows it needs to look into it. */
4092 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_UNSPECIFIED
;
4094 dtp
->u
.p
.current_unit
->current_record
= 0;
4095 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
4097 fp
= stell (dtp
->u
.p
.current_unit
->s
);
4098 /* Calculate next record, rounding up partial records. */
4099 dtp
->u
.p
.current_unit
->last_record
=
4100 (fp
+ dtp
->u
.p
.current_unit
->recl
) /
4101 dtp
->u
.p
.current_unit
->recl
- 1;
4104 dtp
->u
.p
.current_unit
->last_record
++;
4110 smarkeor (dtp
->u
.p
.current_unit
->s
);
4114 /* Finalize the current data transfer. For a nonadvancing transfer,
4115 this means advancing to the next record. For internal units close the
4116 stream associated with the unit. */
4119 finalize_transfer (st_parameter_dt
*dtp
)
4121 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
4123 if ((dtp
->u
.p
.ionml
!= NULL
)
4124 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
4126 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
4128 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
4129 "Namelist formatting for unit connected "
4130 "with FORM='UNFORMATTED'");
4134 dtp
->u
.p
.namelist_mode
= 1;
4135 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
4136 namelist_read (dtp
);
4138 namelist_write (dtp
);
4141 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
4142 *dtp
->size
= dtp
->u
.p
.current_unit
->size_used
;
4144 if (dtp
->u
.p
.eor_condition
)
4146 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
4150 if (dtp
->u
.p
.current_unit
&& (dtp
->u
.p
.current_unit
->child_dtio
> 0))
4152 if (cf
& IOPARM_DT_HAS_FORMAT
)
4154 free (dtp
->u
.p
.fmt
);
4160 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
4162 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
4163 dtp
->u
.p
.current_unit
->current_record
= 0;
4167 dtp
->u
.p
.transfer
= NULL
;
4168 if (dtp
->u
.p
.current_unit
== NULL
)
4171 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
4173 finish_list_read (dtp
);
4177 if (dtp
->u
.p
.mode
== WRITING
)
4178 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
4179 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
4181 if (is_stream_io (dtp
))
4183 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
4184 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
4185 next_record (dtp
, 1);
4190 dtp
->u
.p
.current_unit
->current_record
= 0;
4192 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
4194 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
4195 dtp
->u
.p
.seen_dollar
= 0;
4199 /* For non-advancing I/O, save the current maximum position for use in the
4200 next I/O operation if needed. */
4201 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
4203 if (dtp
->u
.p
.skips
> 0)
4206 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
4207 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
4208 - dtp
->u
.p
.current_unit
->bytes_left
);
4210 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
4213 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
4214 - dtp
->u
.p
.current_unit
->bytes_left
);
4215 dtp
->u
.p
.current_unit
->saved_pos
=
4216 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
4217 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
4220 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
4221 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
4222 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
4224 dtp
->u
.p
.current_unit
->saved_pos
= 0;
4225 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
4226 next_record (dtp
, 1);
4230 if (dtp
->u
.p
.unit_is_internal
)
4232 /* The unit structure may be reused later so clear the
4233 internal unit kind. */
4234 dtp
->u
.p
.current_unit
->internal_unit_kind
= 0;
4236 fbuf_destroy (dtp
->u
.p
.current_unit
);
4237 if (dtp
->u
.p
.current_unit
4238 && (dtp
->u
.p
.current_unit
->child_dtio
== 0)
4239 && dtp
->u
.p
.current_unit
->s
)
4241 sclose (dtp
->u
.p
.current_unit
->s
);
4242 dtp
->u
.p
.current_unit
->s
= NULL
;
4246 #ifdef HAVE_USELOCALE
4247 if (dtp
->u
.p
.old_locale
!= (locale_t
) 0)
4249 uselocale (dtp
->u
.p
.old_locale
);
4250 dtp
->u
.p
.old_locale
= (locale_t
) 0;
4253 __gthread_mutex_lock (&old_locale_lock
);
4254 if (!--old_locale_ctr
)
4256 setlocale (LC_NUMERIC
, old_locale
);
4259 __gthread_mutex_unlock (&old_locale_lock
);
4263 /* Transfer function for IOLENGTH. It doesn't actually do any
4264 data transfer, it just updates the length counter. */
4267 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
4268 void *dest
__attribute__ ((unused
)),
4269 int kind
__attribute__((unused
)),
4270 size_t size
, size_t nelems
)
4272 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
4273 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
4277 /* Initialize the IOLENGTH data transfer. This function is in essence
4278 a very much simplified version of data_transfer_init(), because it
4279 doesn't have to deal with units at all. */
4282 iolength_transfer_init (st_parameter_dt
*dtp
)
4284 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
4287 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
4289 /* Set up the subroutine that will handle the transfers. */
4291 dtp
->u
.p
.transfer
= iolength_transfer
;
4295 /* Library entry point for the IOLENGTH form of the INQUIRE
4296 statement. The IOLENGTH form requires no I/O to be performed, but
4297 it must still be a runtime library call so that we can determine
4298 the iolength for dynamic arrays and such. */
4300 extern void st_iolength (st_parameter_dt
*);
4301 export_proto(st_iolength
);
4304 st_iolength (st_parameter_dt
*dtp
)
4306 library_start (&dtp
->common
);
4307 iolength_transfer_init (dtp
);
4310 extern void st_iolength_done (st_parameter_dt
*);
4311 export_proto(st_iolength_done
);
4314 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
4321 /* The READ statement. */
4323 extern void st_read (st_parameter_dt
*);
4324 export_proto(st_read
);
4327 st_read (st_parameter_dt
*dtp
)
4329 library_start (&dtp
->common
);
4331 data_transfer_init (dtp
, 1);
4334 extern void st_read_done (st_parameter_dt
*);
4335 export_proto(st_read_done
);
4338 st_read_done_worker (st_parameter_dt
*dtp
)
4340 finalize_transfer (dtp
);
4344 /* If this is a parent READ statement we do not need to retain the
4345 internal unit structure for child use. */
4346 if (dtp
->u
.p
.current_unit
!= NULL
4347 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4349 if (dtp
->u
.p
.unit_is_internal
)
4351 if ((dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4353 free (dtp
->u
.p
.current_unit
->filename
);
4354 dtp
->u
.p
.current_unit
->filename
= NULL
;
4355 if (dtp
->u
.p
.current_unit
->ls
)
4356 free (dtp
->u
.p
.current_unit
->ls
);
4357 dtp
->u
.p
.current_unit
->ls
= NULL
;
4359 newunit_free (dtp
->common
.unit
);
4361 if (dtp
->u
.p
.unit_is_internal
|| dtp
->u
.p
.format_not_saved
)
4363 free_format_data (dtp
->u
.p
.fmt
);
4370 st_read_done (st_parameter_dt
*dtp
)
4372 if (dtp
->u
.p
.current_unit
)
4374 if (dtp
->u
.p
.current_unit
->au
)
4376 if (dtp
->common
.flags
& IOPARM_DT_HAS_ID
)
4377 *dtp
->id
= enqueue_done_id (dtp
->u
.p
.current_unit
->au
, AIO_READ_DONE
);
4381 enqueue_done (dtp
->u
.p
.current_unit
->au
, AIO_READ_DONE
);
4385 st_read_done_worker (dtp
);
4387 unlock_unit (dtp
->u
.p
.current_unit
);
4393 extern void st_write (st_parameter_dt
*);
4394 export_proto (st_write
);
4397 st_write (st_parameter_dt
*dtp
)
4399 library_start (&dtp
->common
);
4400 data_transfer_init (dtp
, 0);
4405 st_write_done_worker (st_parameter_dt
*dtp
)
4407 finalize_transfer (dtp
);
4409 if (dtp
->u
.p
.current_unit
!= NULL
4410 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4412 /* Deal with endfile conditions associated with sequential files. */
4413 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4414 switch (dtp
->u
.p
.current_unit
->endfile
)
4416 case AT_ENDFILE
: /* Remain at the endfile record. */
4420 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
4424 /* Get rid of whatever is after this record. */
4425 if (!is_internal_unit (dtp
))
4426 unit_truncate (dtp
->u
.p
.current_unit
,
4427 stell (dtp
->u
.p
.current_unit
->s
),
4429 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4435 /* If this is a parent WRITE statement we do not need to retain the
4436 internal unit structure for child use. */
4437 if (dtp
->u
.p
.unit_is_internal
)
4439 if ((dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4441 free (dtp
->u
.p
.current_unit
->filename
);
4442 dtp
->u
.p
.current_unit
->filename
= NULL
;
4443 if (dtp
->u
.p
.current_unit
->ls
)
4444 free (dtp
->u
.p
.current_unit
->ls
);
4445 dtp
->u
.p
.current_unit
->ls
= NULL
;
4447 newunit_free (dtp
->common
.unit
);
4449 if (dtp
->u
.p
.unit_is_internal
|| dtp
->u
.p
.format_not_saved
)
4451 free_format_data (dtp
->u
.p
.fmt
);
4457 extern void st_write_done (st_parameter_dt
*);
4458 export_proto(st_write_done
);
4461 st_write_done (st_parameter_dt
*dtp
)
4463 if (dtp
->u
.p
.current_unit
)
4465 if (dtp
->u
.p
.current_unit
->au
&& dtp
->u
.p
.async
)
4467 if (dtp
->common
.flags
& IOPARM_DT_HAS_ID
)
4468 *dtp
->id
= enqueue_done_id (dtp
->u
.p
.current_unit
->au
,
4472 /* We perform synchronous I/O on an asynchronous unit, so no need
4473 to enqueue AIO_READ_DONE. */
4475 enqueue_done (dtp
->u
.p
.current_unit
->au
, AIO_WRITE_DONE
);
4479 st_write_done_worker (dtp
);
4481 unlock_unit (dtp
->u
.p
.current_unit
);
4487 /* Wait operation. We need to keep around the do-nothing version
4488 of st_wait for compatibility with previous versions, which had marked
4489 the argument as unused (and thus liable to be removed).
4491 TODO: remove at next bump in version number. */
4494 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
4500 st_wait_async (st_parameter_wait
*wtp
)
4502 gfc_unit
*u
= find_unit (wtp
->common
.unit
);
4503 if (ASYNC_IO
&& u
&& u
->au
)
4505 if (wtp
->common
.flags
& IOPARM_WAIT_HAS_ID
)
4506 async_wait_id (&(wtp
->common
), u
->au
, *wtp
->id
);
4508 async_wait (&(wtp
->common
), u
->au
);
4515 /* Receives the scalar information for namelist objects and stores it
4516 in a linked list of namelist_info types. */
4519 set_nml_var (st_parameter_dt
*dtp
, void *var_addr
, char *var_name
,
4520 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4521 dtype_type dtype
, void *dtio_sub
, void *vtable
)
4523 namelist_info
*t1
= NULL
;
4525 size_t var_name_len
= strlen (var_name
);
4527 nml
= (namelist_info
*) xmalloc (sizeof (namelist_info
));
4529 nml
->mem_pos
= var_addr
;
4530 nml
->dtio_sub
= dtio_sub
;
4531 nml
->vtable
= vtable
;
4533 nml
->var_name
= (char*) xmalloc (var_name_len
+ 1);
4534 memcpy (nml
->var_name
, var_name
, var_name_len
);
4535 nml
->var_name
[var_name_len
] = '\0';
4537 nml
->len
= (int) len
;
4538 nml
->string_length
= (index_type
) string_length
;
4540 nml
->var_rank
= (int) (dtype
.rank
);
4541 nml
->size
= (index_type
) (dtype
.elem_len
);
4542 nml
->type
= (bt
) (dtype
.type
);
4544 if (nml
->var_rank
> 0)
4546 nml
->dim
= (descriptor_dimension
*)
4547 xmallocarray (nml
->var_rank
, sizeof (descriptor_dimension
));
4548 nml
->ls
= (array_loop_spec
*)
4549 xmallocarray (nml
->var_rank
, sizeof (array_loop_spec
));
4559 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
4561 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
4562 dtp
->u
.p
.ionml
= nml
;
4566 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
4571 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
4572 GFC_INTEGER_4
, gfc_charlen_type
, dtype_type
);
4573 export_proto(st_set_nml_var
);
4576 st_set_nml_var (st_parameter_dt
*dtp
, void *var_addr
, char *var_name
,
4577 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4580 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4585 /* Essentially the same as previous but carrying the dtio procedure
4586 and the vtable as additional arguments. */
4587 extern void st_set_nml_dtio_var (st_parameter_dt
*dtp
, void *, char *,
4588 GFC_INTEGER_4
, gfc_charlen_type
, dtype_type
,
4590 export_proto(st_set_nml_dtio_var
);
4594 st_set_nml_dtio_var (st_parameter_dt
*dtp
, void *var_addr
, char *var_name
,
4595 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4596 dtype_type dtype
, void *dtio_sub
, void *vtable
)
4598 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4599 dtype
, dtio_sub
, vtable
);
4602 /* Store the dimensional information for the namelist object. */
4603 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
4604 index_type
, index_type
,
4606 export_proto(st_set_nml_var_dim
);
4609 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
4610 index_type stride
, index_type lbound
,
4618 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
4620 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
4624 /* Once upon a time, a poor innocent Fortran program was reading a
4625 file, when suddenly it hit the end-of-file (EOF). Unfortunately
4626 the OS doesn't tell whether we're at the EOF or whether we already
4627 went past it. Luckily our hero, libgfortran, keeps track of this.
4628 Call this function when you detect an EOF condition. See Section
4632 hit_eof (st_parameter_dt
*dtp
)
4634 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
4636 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4637 switch (dtp
->u
.p
.current_unit
->endfile
)
4641 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4642 if (!is_internal_unit (dtp
) && !dtp
->u
.p
.namelist_mode
)
4644 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
4645 dtp
->u
.p
.current_unit
->current_record
= 0;
4648 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4652 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
4653 dtp
->u
.p
.current_unit
->current_record
= 0;
4658 /* Non-sequential files don't have an ENDFILE record, so we
4659 can't be at AFTER_ENDFILE. */
4660 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4661 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4662 dtp
->u
.p
.current_unit
->current_record
= 0;