1 /* Copyright (C) 2002-2023 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 trailing 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 unit_convert convert
;
1093 if (type
== BT_CLASS
)
1095 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1096 char tmp_iomsg
[IOMSG_LEN
] = "";
1098 gfc_charlen_type child_iomsg_len
;
1100 int *child_iostat
= NULL
;
1102 /* Set iostat, intent(out). */
1104 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1105 dtp
->common
.iostat
: &noiostat
;
1107 /* Set iomsg, intent(inout). */
1108 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1110 child_iomsg
= dtp
->common
.iomsg
;
1111 child_iomsg_len
= dtp
->common
.iomsg_len
;
1115 child_iomsg
= tmp_iomsg
;
1116 child_iomsg_len
= IOMSG_LEN
;
1119 /* Call the user defined unformatted READ procedure. */
1120 dtp
->u
.p
.current_unit
->child_dtio
++;
1121 dtp
->u
.p
.ufdtio_ptr (dest
, &unit
, child_iostat
, child_iomsg
,
1123 dtp
->u
.p
.current_unit
->child_dtio
--;
1127 if (type
== BT_CHARACTER
)
1128 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
1129 read_block_direct (dtp
, dest
, size
* nelems
);
1131 convert
= dtp
->u
.p
.current_unit
->flags
.convert
;
1132 if (unlikely (convert
!= GFC_CONVERT_NATIVE
) && kind
!= 1)
1134 /* Handle wide chracters. */
1135 if (type
== BT_CHARACTER
)
1141 /* Break up complex into its constituent reals. */
1142 else if (type
== BT_COMPLEX
)
1147 #ifndef HAVE_GFC_REAL_17
1148 #if defined(HAVE_GFC_REAL_16) && GFC_REAL_16_DIGITS == 106
1149 /* IBM extended format is stored as a pair of IEEE754
1150 double values, with the more significant value first
1151 in both big and little endian. */
1152 if (kind
== 16 && (type
== BT_REAL
|| type
== BT_COMPLEX
))
1158 bswap_array (dest
, dest
, size
, nelems
);
1160 unit_convert bswap
= convert
& ~(GFC_CONVERT_R16_IEEE
| GFC_CONVERT_R16_IBM
);
1161 if (bswap
== GFC_CONVERT_SWAP
)
1163 if ((type
== BT_REAL
|| type
== BT_COMPLEX
)
1164 && ((kind
== 16 && (convert
& GFC_CONVERT_R16_IEEE
) == 0)
1165 || (kind
== 17 && (convert
& GFC_CONVERT_R16_IBM
))))
1166 bswap_array (dest
, dest
, size
/ 2, nelems
* 2);
1168 bswap_array (dest
, dest
, size
, nelems
);
1171 if ((convert
& GFC_CONVERT_R16_IEEE
)
1173 && (type
== BT_REAL
|| type
== BT_COMPLEX
))
1176 for (size_t i
= 0; i
< nelems
; i
++)
1180 memcpy (&r17
, pd
, 16);
1182 memcpy (pd
, &r16
, 16);
1186 else if ((dtp
->u
.p
.current_unit
->flags
.convert
& GFC_CONVERT_R16_IBM
)
1188 && (type
== BT_REAL
|| type
== BT_COMPLEX
))
1190 if (type
== BT_COMPLEX
&& size
== 32)
1197 for (size_t i
= 0; i
< nelems
; i
++)
1201 memcpy (&r16
, pd
, 16);
1203 memcpy (pd
, &r17
, 16);
1207 #endif /* HAVE_GFC_REAL_17. */
1212 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
1213 bytes on 64 bit machines. The unused bytes are not initialized and never
1214 used, which can show an error with memory checking analyzers like
1215 valgrind. We us BT_CLASS to denote a User Defined I/O call. */
1218 unformatted_write (st_parameter_dt
*dtp
, bt type
,
1219 void *source
, int kind
, size_t size
, size_t nelems
)
1221 unit_convert convert
;
1223 if (type
== BT_CLASS
)
1225 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1226 char tmp_iomsg
[IOMSG_LEN
] = "";
1228 gfc_charlen_type child_iomsg_len
;
1230 int *child_iostat
= NULL
;
1232 /* Set iostat, intent(out). */
1234 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1235 dtp
->common
.iostat
: &noiostat
;
1237 /* Set iomsg, intent(inout). */
1238 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1240 child_iomsg
= dtp
->common
.iomsg
;
1241 child_iomsg_len
= dtp
->common
.iomsg_len
;
1245 child_iomsg
= tmp_iomsg
;
1246 child_iomsg_len
= IOMSG_LEN
;
1249 /* Call the user defined unformatted WRITE procedure. */
1250 dtp
->u
.p
.current_unit
->child_dtio
++;
1251 dtp
->u
.p
.ufdtio_ptr (source
, &unit
, child_iostat
, child_iomsg
,
1253 dtp
->u
.p
.current_unit
->child_dtio
--;
1257 convert
= dtp
->u
.p
.current_unit
->flags
.convert
;
1258 if (likely (convert
== GFC_CONVERT_NATIVE
) || kind
== 1
1259 #ifdef HAVE_GFC_REAL_17
1260 || ((type
== BT_REAL
|| type
== BT_COMPLEX
)
1261 && ((kind
== 16 && convert
== GFC_CONVERT_R16_IBM
)
1262 || (kind
== 17 && convert
== GFC_CONVERT_R16_IEEE
)))
1266 size_t stride
= type
== BT_CHARACTER
?
1267 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1269 write_buf (dtp
, source
, stride
* nelems
);
1273 #define BSWAP_BUFSZ 512
1274 char buffer
[BSWAP_BUFSZ
];
1280 /* Handle wide chracters. */
1281 if (type
== BT_CHARACTER
&& kind
!= 1)
1287 /* Break up complex into its constituent reals. */
1288 if (type
== BT_COMPLEX
)
1294 #if !defined(HAVE_GFC_REAL_17) && defined(HAVE_GFC_REAL_16) \
1295 && GFC_REAL_16_DIGITS == 106
1296 /* IBM extended format is stored as a pair of IEEE754
1297 double values, with the more significant value first
1298 in both big and little endian. */
1299 if (kind
== 16 && (type
== BT_REAL
|| type
== BT_COMPLEX
))
1306 /* By now, all complex variables have been split into their
1307 constituent reals. */
1313 if (size
* nrem
> BSWAP_BUFSZ
)
1314 nc
= BSWAP_BUFSZ
/ size
;
1318 #ifdef HAVE_GFC_REAL_17
1319 if ((dtp
->u
.p
.current_unit
->flags
.convert
& GFC_CONVERT_R16_IEEE
)
1321 && (type
== BT_REAL
|| type
== BT_COMPLEX
))
1323 for (size_t i
= 0; i
< nc
; i
++)
1327 memcpy (&r16
, p
, 16);
1329 memcpy (&buffer
[i
* 16], &r17
, 16);
1332 if ((dtp
->u
.p
.current_unit
->flags
.convert
1333 & ~(GFC_CONVERT_R16_IEEE
| GFC_CONVERT_R16_IBM
))
1334 == GFC_CONVERT_SWAP
)
1335 bswap_array (buffer
, buffer
, size
, nc
);
1337 else if ((dtp
->u
.p
.current_unit
->flags
.convert
& GFC_CONVERT_R16_IBM
)
1339 && (type
== BT_REAL
|| type
== BT_COMPLEX
))
1341 for (size_t i
= 0; i
< nc
; i
++)
1345 memcpy (&r17
, p
, 16);
1347 memcpy (&buffer
[i
* 16], &r16
, 16);
1350 if ((dtp
->u
.p
.current_unit
->flags
.convert
1351 & ~(GFC_CONVERT_R16_IEEE
| GFC_CONVERT_R16_IBM
))
1352 == GFC_CONVERT_SWAP
)
1353 bswap_array (buffer
, buffer
, size
/ 2, nc
* 2);
1355 else if (kind
== 16 && (type
== BT_REAL
|| type
== BT_COMPLEX
))
1357 bswap_array (buffer
, p
, size
/ 2, nc
* 2);
1363 bswap_array (buffer
, p
, size
, nc
);
1366 write_buf (dtp
, buffer
, size
* nc
);
1374 /* Return a pointer to the name of a type. */
1399 p
= "CLASS or DERIVED";
1402 internal_error (NULL
, "type_name(): Bad type");
1409 /* Write a constant string to the output.
1410 This is complicated because the string can have doubled delimiters
1411 in it. The length in the format node is the true length. */
1414 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
1416 char c
, delimiter
, *p
, *q
;
1419 length
= f
->u
.string
.length
;
1423 p
= write_block (dtp
, length
);
1430 for (; length
> 0; length
--)
1433 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
1434 q
++; /* Skip the doubled delimiter. */
1439 /* Given actual and expected types in a formatted data transfer, make
1440 sure they agree. If not, an error message is generated. Returns
1441 nonzero if something went wrong. */
1444 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
1447 char buffer
[BUFLEN
];
1449 if (actual
== expected
)
1452 /* Adjust item_count before emitting error message. */
1453 snprintf (buffer
, BUFLEN
,
1454 "Expected %s for item %d in formatted transfer, got %s",
1455 type_name (expected
), dtp
->u
.p
.item_count
- 1, type_name (actual
));
1457 format_error (dtp
, f
, buffer
);
1462 /* Check that the dtio procedure required for formatted IO is present. */
1465 check_dtio_proc (st_parameter_dt
*dtp
, const fnode
*f
)
1467 char buffer
[BUFLEN
];
1469 if (dtp
->u
.p
.fdtio_ptr
!= NULL
)
1472 snprintf (buffer
, BUFLEN
,
1473 "Missing DTIO procedure or intrinsic type passed for item %d "
1474 "in formatted transfer",
1475 dtp
->u
.p
.item_count
- 1);
1477 format_error (dtp
, f
, buffer
);
1483 require_numeric_type (st_parameter_dt
*dtp
, bt actual
, const fnode
*f
)
1486 char buffer
[BUFLEN
];
1488 if (actual
== BT_INTEGER
|| actual
== BT_REAL
|| actual
== BT_COMPLEX
)
1491 /* Adjust item_count before emitting error message. */
1492 snprintf (buffer
, BUFLEN
,
1493 "Expected numeric type for item %d in formatted transfer, got %s",
1494 dtp
->u
.p
.item_count
- 1, type_name (actual
));
1496 format_error (dtp
, f
, buffer
);
1501 get_dt_format (char *p
, gfc_charlen_type
*length
)
1503 char delim
= p
[-1]; /* The delimiter is always the first character back. */
1505 gfc_charlen_type len
= *length
; /* This length already correct, less 'DT'. */
1507 res
= q
= xmalloc (len
+ 2);
1509 /* Set the beginning of the string to 'DT', length adjusted below. */
1513 /* The string may contain doubled quotes so scan and skip as needed. */
1514 for (; len
> 0; len
--)
1518 p
++; /* Skip the doubled delimiter. */
1521 /* Adjust the string length by two now that we are done. */
1528 /* This function is in the main loop for a formatted data transfer
1529 statement. It would be natural to implement this as a coroutine
1530 with the user program, but C makes that awkward. We loop,
1531 processing format elements. When we actually have to transfer
1532 data instead of just setting flags, we return control to the user
1533 program which calls a function that supplies the address and type
1534 of the next element, then comes back here to process it. */
1537 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1540 int pos
, bytes_used
;
1544 int consume_data_flag
;
1546 /* Change a complex data item into a pair of reals. */
1548 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1549 if (type
== BT_COMPLEX
)
1555 /* If there's an EOR condition, we simulate finalizing the transfer
1556 by doing nothing. */
1557 if (dtp
->u
.p
.eor_condition
)
1560 /* Set this flag so that commas in reads cause the read to complete before
1561 the entire field has been read. The next read field will start right after
1562 the comma in the stream. (Set to 0 for character reads). */
1563 dtp
->u
.p
.sf_read_comma
=
1564 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1568 /* If reversion has occurred and there is another real data item,
1569 then we have to move to the next record. */
1570 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1572 dtp
->u
.p
.reversion_flag
= 0;
1573 next_record (dtp
, 0);
1576 consume_data_flag
= 1;
1577 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1580 f
= next_format (dtp
);
1583 /* No data descriptors left. */
1584 if (unlikely (n
> 0))
1585 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1586 "Insufficient data descriptors in format after reversion");
1592 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1593 - dtp
->u
.p
.current_unit
->bytes_left
);
1595 if (is_stream_io(dtp
))
1602 goto need_read_data
;
1603 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1605 read_decimal (dtp
, f
, p
, kind
);
1610 goto need_read_data
;
1611 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1612 && require_numeric_type (dtp
, type
, f
))
1614 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1615 && require_type (dtp
, BT_INTEGER
, type
, f
))
1617 #ifdef HAVE_GFC_REAL_17
1618 if (type
== BT_REAL
&& kind
== 17)
1621 read_radix (dtp
, f
, p
, kind
, 2);
1626 goto need_read_data
;
1627 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1628 && require_numeric_type (dtp
, type
, f
))
1630 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1631 && require_type (dtp
, BT_INTEGER
, type
, f
))
1633 #ifdef HAVE_GFC_REAL_17
1634 if (type
== BT_REAL
&& kind
== 17)
1637 read_radix (dtp
, f
, p
, kind
, 8);
1642 goto need_read_data
;
1643 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1644 && require_numeric_type (dtp
, type
, f
))
1646 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1647 && require_type (dtp
, BT_INTEGER
, type
, f
))
1649 #ifdef HAVE_GFC_REAL_17
1650 if (type
== BT_REAL
&& kind
== 17)
1653 read_radix (dtp
, f
, p
, kind
, 16);
1658 goto need_read_data
;
1660 /* It is possible to have FMT_A with something not BT_CHARACTER such
1661 as when writing out hollerith strings, so check both type
1662 and kind before calling wide character routines. */
1663 if (type
== BT_CHARACTER
&& kind
== 4)
1664 read_a_char4 (dtp
, f
, p
, size
);
1666 read_a (dtp
, f
, p
, size
);
1671 goto need_read_data
;
1672 read_l (dtp
, f
, p
, kind
);
1677 goto need_read_data
;
1678 if (require_type (dtp
, BT_REAL
, type
, f
))
1680 read_f (dtp
, f
, p
, kind
);
1685 goto need_read_data
;
1687 if (check_dtio_proc (dtp
, f
))
1689 if (require_type (dtp
, BT_CLASS
, type
, f
))
1691 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1693 char tmp_iomsg
[IOMSG_LEN
] = "";
1695 gfc_charlen_type child_iomsg_len
;
1697 int *child_iostat
= NULL
;
1699 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1701 /* Build the iotype string. */
1702 if (iotype_len
== 0)
1708 iotype
= get_dt_format (f
->u
.udf
.string
, &iotype_len
);
1710 /* Set iostat, intent(out). */
1712 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1713 dtp
->common
.iostat
: &noiostat
;
1715 /* Set iomsg, intent(inout). */
1716 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1718 child_iomsg
= dtp
->common
.iomsg
;
1719 child_iomsg_len
= dtp
->common
.iomsg_len
;
1723 child_iomsg
= tmp_iomsg
;
1724 child_iomsg_len
= IOMSG_LEN
;
1727 /* Call the user defined formatted READ procedure. */
1728 dtp
->u
.p
.current_unit
->child_dtio
++;
1729 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
1730 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1731 child_iostat
, child_iomsg
,
1732 iotype_len
, child_iomsg_len
);
1733 dtp
->u
.p
.current_unit
->child_dtio
--;
1735 if (f
->u
.udf
.string_len
!= 0)
1737 /* Note: vlist is freed in free_format_data. */
1742 goto need_read_data
;
1743 if (require_type (dtp
, BT_REAL
, type
, f
))
1745 read_f (dtp
, f
, p
, kind
);
1750 goto need_read_data
;
1751 if (require_type (dtp
, BT_REAL
, type
, f
))
1753 read_f (dtp
, f
, p
, kind
);
1758 goto need_read_data
;
1759 if (require_type (dtp
, BT_REAL
, type
, f
))
1761 read_f (dtp
, f
, p
, kind
);
1766 goto need_read_data
;
1767 if (require_type (dtp
, BT_REAL
, type
, f
))
1769 read_f (dtp
, f
, p
, kind
);
1774 goto need_read_data
;
1778 read_decimal (dtp
, f
, p
, kind
);
1781 read_l (dtp
, f
, p
, kind
);
1785 read_a_char4 (dtp
, f
, p
, size
);
1787 read_a (dtp
, f
, p
, size
);
1790 read_f (dtp
, f
, p
, kind
);
1793 internal_error (&dtp
->common
,
1794 "formatted_transfer (): Bad type");
1799 consume_data_flag
= 0;
1800 format_error (dtp
, f
, "Constant string in input format");
1803 /* Format codes that don't transfer data. */
1806 consume_data_flag
= 0;
1807 dtp
->u
.p
.skips
+= f
->u
.n
;
1808 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1809 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1810 read_x (dtp
, f
->u
.n
);
1815 consume_data_flag
= 0;
1817 if (f
->format
== FMT_TL
)
1819 /* Handle the special case when no bytes have been used yet.
1820 Cannot go below zero. */
1821 if (bytes_used
== 0)
1823 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1824 dtp
->u
.p
.skips
-= f
->u
.n
;
1825 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1828 pos
= bytes_used
- f
->u
.n
;
1833 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1834 left tab limit. We do not check if the position has gone
1835 beyond the end of record because a subsequent tab could
1836 bring us back again. */
1837 pos
= pos
< 0 ? 0 : pos
;
1839 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1840 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1841 + pos
- dtp
->u
.p
.max_pos
;
1842 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1843 ? 0 : dtp
->u
.p
.pending_spaces
;
1844 if (dtp
->u
.p
.skips
== 0)
1847 /* Adjust everything for end-of-record condition */
1848 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1850 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1851 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1853 if (dtp
->u
.p
.pending_spaces
== 0)
1854 dtp
->u
.p
.sf_seen_eor
= 0;
1856 if (dtp
->u
.p
.skips
< 0)
1858 if (is_internal_unit (dtp
))
1859 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1861 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1862 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1863 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1866 read_x (dtp
, dtp
->u
.p
.skips
);
1870 consume_data_flag
= 0;
1871 dtp
->u
.p
.sign_status
= SIGN_PROCDEFINED
;
1875 consume_data_flag
= 0;
1876 dtp
->u
.p
.sign_status
= SIGN_SUPPRESS
;
1880 consume_data_flag
= 0;
1881 dtp
->u
.p
.sign_status
= SIGN_PLUS
;
1885 consume_data_flag
= 0 ;
1886 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1890 consume_data_flag
= 0;
1891 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1895 consume_data_flag
= 0;
1896 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1900 consume_data_flag
= 0;
1901 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1905 consume_data_flag
= 0;
1906 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1910 consume_data_flag
= 0;
1911 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1915 consume_data_flag
= 0;
1916 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1920 consume_data_flag
= 0;
1921 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1925 consume_data_flag
= 0;
1926 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1930 consume_data_flag
= 0;
1931 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1935 consume_data_flag
= 0;
1936 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1940 consume_data_flag
= 0;
1941 dtp
->u
.p
.seen_dollar
= 1;
1945 consume_data_flag
= 0;
1946 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1947 next_record (dtp
, 0);
1951 /* A colon descriptor causes us to exit this loop (in
1952 particular preventing another / descriptor from being
1953 processed) unless there is another data item to be
1955 consume_data_flag
= 0;
1961 internal_error (&dtp
->common
, "Bad format node");
1964 /* Adjust the item count and data pointer. */
1966 if ((consume_data_flag
> 0) && (n
> 0))
1969 p
= ((char *) p
) + size
;
1974 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1975 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1980 /* Come here when we need a data descriptor but don't have one. We
1981 push the current format node back onto the input, then return and
1982 let the user program call us back with the data. */
1984 unget_format (dtp
, f
);
1989 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1992 gfc_offset pos
, bytes_used
;
1996 int consume_data_flag
;
1998 /* Change a complex data item into a pair of reals. */
2000 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
2001 if (type
== BT_COMPLEX
)
2007 /* If there's an EOR condition, we simulate finalizing the transfer
2008 by doing nothing. */
2009 if (dtp
->u
.p
.eor_condition
)
2012 /* Set this flag so that commas in reads cause the read to complete before
2013 the entire field has been read. The next read field will start right after
2014 the comma in the stream. (Set to 0 for character reads). */
2015 dtp
->u
.p
.sf_read_comma
=
2016 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
2020 /* If reversion has occurred and there is another real data item,
2021 then we have to move to the next record. */
2022 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
2024 dtp
->u
.p
.reversion_flag
= 0;
2025 next_record (dtp
, 0);
2028 consume_data_flag
= 1;
2029 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2032 f
= next_format (dtp
);
2035 /* No data descriptors left. */
2036 if (unlikely (n
> 0))
2037 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
2038 "Insufficient data descriptors in format after reversion");
2042 /* Now discharge T, TR and X movements to the right. This is delayed
2043 until a data producing format to suppress trailing spaces. */
2046 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
2047 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
2048 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
2049 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
2050 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
2052 || t
== FMT_STRING
))
2054 if (dtp
->u
.p
.skips
> 0)
2057 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
2058 tmp
= dtp
->u
.p
.current_unit
->recl
2059 - dtp
->u
.p
.current_unit
->bytes_left
;
2061 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
2064 if (dtp
->u
.p
.skips
< 0)
2066 if (is_internal_unit (dtp
))
2067 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
2069 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
2070 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
2072 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2075 bytes_used
= dtp
->u
.p
.current_unit
->recl
2076 - dtp
->u
.p
.current_unit
->bytes_left
;
2078 if (is_stream_io(dtp
))
2086 if (require_type (dtp
, BT_INTEGER
, type
, f
))
2088 write_i (dtp
, f
, p
, kind
);
2094 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
2095 && require_numeric_type (dtp
, type
, f
))
2097 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
2098 && require_type (dtp
, BT_INTEGER
, type
, f
))
2100 #ifdef HAVE_GFC_REAL_17
2101 if (type
== BT_REAL
&& kind
== 17)
2104 write_b (dtp
, f
, p
, kind
);
2110 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
2111 && require_numeric_type (dtp
, type
, f
))
2113 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
2114 && require_type (dtp
, BT_INTEGER
, type
, f
))
2116 #ifdef HAVE_GFC_REAL_17
2117 if (type
== BT_REAL
&& kind
== 17)
2120 write_o (dtp
, f
, p
, kind
);
2126 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
2127 && require_numeric_type (dtp
, type
, f
))
2129 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
2130 && require_type (dtp
, BT_INTEGER
, type
, f
))
2132 #ifdef HAVE_GFC_REAL_17
2133 if (type
== BT_REAL
&& kind
== 17)
2136 write_z (dtp
, f
, p
, kind
);
2143 /* It is possible to have FMT_A with something not BT_CHARACTER such
2144 as when writing out hollerith strings, so check both type
2145 and kind before calling wide character routines. */
2146 if (type
== BT_CHARACTER
&& kind
== 4)
2147 write_a_char4 (dtp
, f
, p
, size
);
2149 write_a (dtp
, f
, p
, size
);
2155 write_l (dtp
, f
, p
, kind
);
2161 if (require_type (dtp
, BT_REAL
, type
, f
))
2163 if (f
->u
.real
.w
== 0)
2164 write_real_w0 (dtp
, p
, kind
, f
);
2166 write_d (dtp
, f
, p
, kind
);
2172 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
2174 char tmp_iomsg
[IOMSG_LEN
] = "";
2176 gfc_charlen_type child_iomsg_len
;
2178 int *child_iostat
= NULL
;
2180 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
2182 /* Build the iotype string. */
2183 if (iotype_len
== 0)
2189 iotype
= get_dt_format (f
->u
.udf
.string
, &iotype_len
);
2191 /* Set iostat, intent(out). */
2193 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
2194 dtp
->common
.iostat
: &noiostat
;
2196 /* Set iomsg, intent(inout). */
2197 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
2199 child_iomsg
= dtp
->common
.iomsg
;
2200 child_iomsg_len
= dtp
->common
.iomsg_len
;
2204 child_iomsg
= tmp_iomsg
;
2205 child_iomsg_len
= IOMSG_LEN
;
2208 if (check_dtio_proc (dtp
, f
))
2211 /* Call the user defined formatted WRITE procedure. */
2212 dtp
->u
.p
.current_unit
->child_dtio
++;
2214 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
2215 child_iostat
, child_iomsg
,
2216 iotype_len
, child_iomsg_len
);
2217 dtp
->u
.p
.current_unit
->child_dtio
--;
2219 if (f
->u
.udf
.string_len
!= 0)
2221 /* Note: vlist is freed in free_format_data. */
2227 if (require_type (dtp
, BT_REAL
, type
, f
))
2229 if (f
->u
.real
.w
== 0)
2230 write_real_w0 (dtp
, p
, kind
, f
);
2232 write_e (dtp
, f
, p
, kind
);
2238 if (require_type (dtp
, BT_REAL
, type
, f
))
2240 if (f
->u
.real
.w
== 0)
2241 write_real_w0 (dtp
, p
, kind
, f
);
2243 write_en (dtp
, f
, p
, kind
);
2249 if (require_type (dtp
, BT_REAL
, type
, f
))
2251 if (f
->u
.real
.w
== 0)
2252 write_real_w0 (dtp
, p
, kind
, f
);
2254 write_es (dtp
, f
, p
, kind
);
2260 if (require_type (dtp
, BT_REAL
, type
, f
))
2262 write_f (dtp
, f
, p
, kind
);
2271 write_i (dtp
, f
, p
, kind
);
2274 write_l (dtp
, f
, p
, kind
);
2278 write_a_char4 (dtp
, f
, p
, size
);
2280 write_a (dtp
, f
, p
, size
);
2283 if (f
->u
.real
.w
== 0)
2284 write_real_w0 (dtp
, p
, kind
, f
);
2286 write_d (dtp
, f
, p
, kind
);
2289 internal_error (&dtp
->common
,
2290 "formatted_transfer (): Bad type");
2295 consume_data_flag
= 0;
2296 write_constant_string (dtp
, f
);
2299 /* Format codes that don't transfer data. */
2302 consume_data_flag
= 0;
2304 dtp
->u
.p
.skips
+= f
->u
.n
;
2305 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
2306 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
2307 /* Writes occur just before the switch on f->format, above, so
2308 that trailing blanks are suppressed, unless we are doing a
2309 non-advancing write in which case we want to output the blanks
2311 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2313 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
2314 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2320 consume_data_flag
= 0;
2322 if (f
->format
== FMT_TL
)
2325 /* Handle the special case when no bytes have been used yet.
2326 Cannot go below zero. */
2327 if (bytes_used
== 0)
2329 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
2330 dtp
->u
.p
.skips
-= f
->u
.n
;
2331 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
2334 pos
= bytes_used
- f
->u
.n
;
2337 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
2339 /* Standard 10.6.1.1: excessive left tabbing is reset to the
2340 left tab limit. We do not check if the position has gone
2341 beyond the end of record because a subsequent tab could
2342 bring us back again. */
2343 pos
= pos
< 0 ? 0 : pos
;
2345 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
2346 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
2347 + pos
- dtp
->u
.p
.max_pos
;
2348 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
2349 ? 0 : dtp
->u
.p
.pending_spaces
;
2353 consume_data_flag
= 0;
2354 dtp
->u
.p
.sign_status
= SIGN_PROCDEFINED
;
2358 consume_data_flag
= 0;
2359 dtp
->u
.p
.sign_status
= SIGN_SUPPRESS
;
2363 consume_data_flag
= 0;
2364 dtp
->u
.p
.sign_status
= SIGN_PLUS
;
2368 consume_data_flag
= 0 ;
2369 dtp
->u
.p
.blank_status
= BLANK_NULL
;
2373 consume_data_flag
= 0;
2374 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
2378 consume_data_flag
= 0;
2379 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
2383 consume_data_flag
= 0;
2384 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
2388 consume_data_flag
= 0;
2389 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
2393 consume_data_flag
= 0;
2394 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
2398 consume_data_flag
= 0;
2399 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
2403 consume_data_flag
= 0;
2404 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
2408 consume_data_flag
= 0;
2409 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
2413 consume_data_flag
= 0;
2414 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
2418 consume_data_flag
= 0;
2419 dtp
->u
.p
.scale_factor
= f
->u
.k
;
2423 consume_data_flag
= 0;
2424 dtp
->u
.p
.seen_dollar
= 1;
2428 consume_data_flag
= 0;
2429 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2430 next_record (dtp
, 0);
2434 /* A colon descriptor causes us to exit this loop (in
2435 particular preventing another / descriptor from being
2436 processed) unless there is another data item to be
2438 consume_data_flag
= 0;
2444 internal_error (&dtp
->common
, "Bad format node");
2447 /* Adjust the item count and data pointer. */
2449 if ((consume_data_flag
> 0) && (n
> 0))
2452 p
= ((char *) p
) + size
;
2455 pos
= dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
;
2456 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
2461 /* Come here when we need a data descriptor but don't have one. We
2462 push the current format node back onto the input, then return and
2463 let the user program call us back with the data. */
2465 unget_format (dtp
, f
);
2468 /* This function is first called from data_init_transfer to initiate the loop
2469 over each item in the format, transferring data as required. Subsequent
2470 calls to this function occur for each data item foound in the READ/WRITE
2471 statement. The item_count is incremented for each call. Since the first
2472 call is from data_transfer_init, the item_count is always one greater than
2473 the actual count number of the item being transferred. */
2476 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2477 size_t size
, size_t nelems
)
2483 size_t stride
= type
== BT_CHARACTER
?
2484 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2485 if (dtp
->u
.p
.mode
== READING
)
2487 /* Big loop over all the elements. */
2488 for (elem
= 0; elem
< nelems
; elem
++)
2490 dtp
->u
.p
.item_count
++;
2491 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2496 /* Big loop over all the elements. */
2497 for (elem
= 0; elem
< nelems
; elem
++)
2499 dtp
->u
.p
.item_count
++;
2500 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2505 /* Wrapper function for I/O of scalar types. If this should be an async I/O
2506 request, queue it. For a synchronous write on an async unit, perform the
2507 wait operation and return an error. For all synchronous writes, call the
2508 right transfer function. */
2511 wrap_scalar_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2512 size_t size
, size_t n_elem
)
2514 if (dtp
->u
.p
.current_unit
&& dtp
->u
.p
.current_unit
->au
)
2519 args
.scalar
.transfer
= dtp
->u
.p
.transfer
;
2520 args
.scalar
.arg_bt
= type
;
2521 args
.scalar
.data
= p
;
2522 args
.scalar
.i
= kind
;
2523 args
.scalar
.s1
= size
;
2524 args
.scalar
.s2
= n_elem
;
2525 enqueue_transfer (dtp
->u
.p
.current_unit
->au
, &args
,
2526 AIO_TRANSFER_SCALAR
);
2530 /* Come here if there was no asynchronous I/O to be scheduled. */
2531 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2534 dtp
->u
.p
.transfer (dtp
, type
, p
, kind
, size
, 1);
2538 /* Data transfer entry points. The type of the data entity is
2539 implicit in the subroutine call. This prevents us from having to
2540 share a common enum with the compiler. */
2543 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
2545 wrap_scalar_transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
2549 transfer_integer_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2551 transfer_integer (dtp
, p
, kind
);
2555 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
2558 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2560 size
= size_from_real_kind (kind
);
2561 wrap_scalar_transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
2565 transfer_real_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2567 transfer_real (dtp
, p
, kind
);
2571 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
2573 wrap_scalar_transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
2577 transfer_logical_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2579 transfer_logical (dtp
, p
, kind
);
2583 transfer_character (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
)
2585 static char *empty_string
[0];
2587 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2590 /* Strings of zero length can have p == NULL, which confuses the
2591 transfer routines into thinking we need more data elements. To avoid
2592 this, we give them a nice pointer. */
2593 if (len
== 0 && p
== NULL
)
2596 /* Set kind here to 1. */
2597 wrap_scalar_transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
2601 transfer_character_write (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
)
2603 transfer_character (dtp
, p
, len
);
2607 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
, int kind
)
2609 static char *empty_string
[0];
2611 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2614 /* Strings of zero length can have p == NULL, which confuses the
2615 transfer routines into thinking we need more data elements. To avoid
2616 this, we give them a nice pointer. */
2617 if (len
== 0 && p
== NULL
)
2620 /* Here we pass the actual kind value. */
2621 wrap_scalar_transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
2625 transfer_character_wide_write (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
, int kind
)
2627 transfer_character_wide (dtp
, p
, len
, kind
);
2631 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
2634 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2636 size
= size_from_complex_kind (kind
);
2637 wrap_scalar_transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
2641 transfer_complex_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2643 transfer_complex (dtp
, p
, kind
);
2647 transfer_array_inner (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2648 gfc_charlen_type charlen
)
2650 index_type count
[GFC_MAX_DIMENSIONS
];
2651 index_type extent
[GFC_MAX_DIMENSIONS
];
2652 index_type stride
[GFC_MAX_DIMENSIONS
];
2653 index_type stride0
, rank
, size
, n
;
2658 /* Adjust item_count before emitting error message. */
2660 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2663 iotype
= (bt
) GFC_DESCRIPTOR_TYPE (desc
);
2664 size
= iotype
== BT_CHARACTER
? charlen
: GFC_DESCRIPTOR_SIZE (desc
);
2666 rank
= GFC_DESCRIPTOR_RANK (desc
);
2668 for (n
= 0; n
< rank
; n
++)
2671 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
2672 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
2674 /* If the extent of even one dimension is zero, then the entire
2675 array section contains zero elements, so we return after writing
2676 a zero array record. */
2681 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2686 stride0
= stride
[0];
2688 /* If the innermost dimension has a stride of 1, we can do the transfer
2689 in contiguous chunks. */
2690 if (stride0
== size
)
2695 data
= GFC_DESCRIPTOR_DATA (desc
);
2697 /* When reading, we need to check endfile conditions so we do not miss
2698 an END=label. Make this separate so we do not have an extra test
2699 in a tight loop when it is not needed. */
2701 if (dtp
->u
.p
.current_unit
&& dtp
->u
.p
.mode
== READING
)
2705 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
))
2708 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2709 data
+= stride0
* tsize
;
2712 while (count
[n
] == extent
[n
])
2715 data
-= stride
[n
] * extent
[n
];
2734 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2735 data
+= stride0
* tsize
;
2738 while (count
[n
] == extent
[n
])
2741 data
-= stride
[n
] * extent
[n
];
2759 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2760 gfc_charlen_type charlen
)
2762 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2765 if (dtp
->u
.p
.current_unit
&& dtp
->u
.p
.current_unit
->au
)
2770 size_t sz
= sizeof (gfc_array_char
)
2771 + sizeof (descriptor_dimension
)
2772 * GFC_DESCRIPTOR_RANK (desc
);
2773 args
.array
.desc
= xmalloc (sz
);
2774 NOTE ("desc = %p", (void *) args
.array
.desc
);
2775 memcpy (args
.array
.desc
, desc
, sz
);
2776 args
.array
.kind
= kind
;
2777 args
.array
.charlen
= charlen
;
2778 enqueue_transfer (dtp
->u
.p
.current_unit
->au
, &args
,
2779 AIO_TRANSFER_ARRAY
);
2783 /* Come here if there was no asynchronous I/O to be scheduled. */
2784 transfer_array_inner (dtp
, desc
, kind
, charlen
);
2789 transfer_array_write (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2790 gfc_charlen_type charlen
)
2792 transfer_array (dtp
, desc
, kind
, charlen
);
2796 /* User defined input/output iomsg. */
2798 #define IOMSG_LEN 256
2801 transfer_derived (st_parameter_dt
*parent
, void *dtio_source
, void *dtio_proc
)
2803 if (parent
->u
.p
.current_unit
)
2805 if (parent
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2806 parent
->u
.p
.ufdtio_ptr
= (unformatted_dtio
) dtio_proc
;
2808 parent
->u
.p
.fdtio_ptr
= (formatted_dtio
) dtio_proc
;
2810 wrap_scalar_transfer (parent
, BT_CLASS
, dtio_source
, 0, 0, 1);
2814 /* Preposition a sequential unformatted file while reading. */
2817 us_read (st_parameter_dt
*dtp
, int continued
)
2824 if (compile_options
.record_marker
== 0)
2825 n
= sizeof (GFC_INTEGER_4
);
2827 n
= compile_options
.record_marker
;
2829 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
2830 if (unlikely (nr
< 0))
2832 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2838 return; /* end of file */
2840 else if (unlikely (n
!= nr
))
2842 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2846 int convert
= dtp
->u
.p
.current_unit
->flags
.convert
;
2847 #ifdef HAVE_GFC_REAL_17
2848 convert
&= ~(GFC_CONVERT_R16_IEEE
| GFC_CONVERT_R16_IBM
);
2850 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2851 if (likely (convert
== GFC_CONVERT_NATIVE
))
2855 case sizeof(GFC_INTEGER_4
):
2856 memcpy (&i4
, &i
, sizeof (i4
));
2860 case sizeof(GFC_INTEGER_8
):
2861 memcpy (&i8
, &i
, sizeof (i8
));
2866 runtime_error ("Illegal value for record marker");
2876 case sizeof(GFC_INTEGER_4
):
2877 memcpy (&u32
, &i
, sizeof (u32
));
2878 u32
= __builtin_bswap32 (u32
);
2879 memcpy (&i4
, &u32
, sizeof (i4
));
2883 case sizeof(GFC_INTEGER_8
):
2884 memcpy (&u64
, &i
, sizeof (u64
));
2885 u64
= __builtin_bswap64 (u64
);
2886 memcpy (&i8
, &u64
, sizeof (i8
));
2891 runtime_error ("Illegal value for record marker");
2898 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
2899 dtp
->u
.p
.current_unit
->continued
= 0;
2903 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
2904 dtp
->u
.p
.current_unit
->continued
= 1;
2908 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2912 /* Preposition a sequential unformatted file while writing. This
2913 amount to writing a bogus length that will be filled in later. */
2916 us_write (st_parameter_dt
*dtp
, int continued
)
2923 if (compile_options
.record_marker
== 0)
2924 nbytes
= sizeof (GFC_INTEGER_4
);
2926 nbytes
= compile_options
.record_marker
;
2928 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2929 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2931 /* For sequential unformatted, if RECL= was not specified in the OPEN
2932 we write until we have more bytes than can fit in the subrecord
2933 markers, then we write a new subrecord. */
2935 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2936 dtp
->u
.p
.current_unit
->recl_subrecord
;
2937 dtp
->u
.p
.current_unit
->continued
= continued
;
2941 /* Position to the next record prior to transfer. We are assumed to
2942 be before the next record. We also calculate the bytes in the next
2946 pre_position (st_parameter_dt
*dtp
)
2948 if (dtp
->u
.p
.current_unit
->current_record
)
2949 return; /* Already positioned. */
2951 switch (current_mode (dtp
))
2953 case FORMATTED_STREAM
:
2954 case UNFORMATTED_STREAM
:
2955 /* There are no records with stream I/O. If the position was specified
2956 data_transfer_init has already positioned the file. If no position
2957 was specified, we continue from where we last left off. I.e.
2958 there is nothing to do here. */
2961 case UNFORMATTED_SEQUENTIAL
:
2962 if (dtp
->u
.p
.mode
== READING
)
2969 case FORMATTED_SEQUENTIAL
:
2970 case FORMATTED_DIRECT
:
2971 case UNFORMATTED_DIRECT
:
2972 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2974 case FORMATTED_UNSPECIFIED
:
2978 dtp
->u
.p
.current_unit
->current_record
= 1;
2982 /* Initialize things for a data transfer. This code is common for
2983 both reading and writing. */
2986 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2988 unit_flags u_flags
; /* Used for creating a unit if needed. */
2989 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2990 namelist_info
*ionml
;
2993 NOTE ("data_transfer_init");
2995 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2997 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2999 dtp
->u
.p
.ionml
= ionml
;
3000 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
3001 dtp
->u
.p
.namelist_mode
= 0;
3002 dtp
->u
.p
.cc
.len
= 0;
3004 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3007 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
3009 if (dtp
->u
.p
.current_unit
== NULL
)
3011 /* This means we tried to access an external unit < 0 without
3012 having opened it first with NEWUNIT=. */
3013 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3014 "Unit number is negative and unit was not already "
3015 "opened with OPEN(NEWUNIT=...)");
3018 else if (dtp
->u
.p
.current_unit
->s
== NULL
)
3019 { /* Open the unit with some default flags. */
3020 st_parameter_open opp
;
3022 NOTE ("Open the unit with some default flags.");
3023 memset (&u_flags
, '\0', sizeof (u_flags
));
3024 u_flags
.access
= ACCESS_SEQUENTIAL
;
3025 u_flags
.action
= ACTION_READWRITE
;
3027 /* Is it unformatted? */
3028 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
3029 | IOPARM_DT_IONML_SET
)))
3030 u_flags
.form
= FORM_UNFORMATTED
;
3032 u_flags
.form
= FORM_UNSPECIFIED
;
3034 u_flags
.delim
= DELIM_UNSPECIFIED
;
3035 u_flags
.blank
= BLANK_UNSPECIFIED
;
3036 u_flags
.pad
= PAD_UNSPECIFIED
;
3037 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
3038 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
3039 u_flags
.async
= ASYNC_UNSPECIFIED
;
3040 u_flags
.round
= ROUND_UNSPECIFIED
;
3041 u_flags
.sign
= SIGN_UNSPECIFIED
;
3042 u_flags
.share
= SHARE_UNSPECIFIED
;
3043 u_flags
.cc
= CC_UNSPECIFIED
;
3044 u_flags
.readonly
= 0;
3046 u_flags
.status
= STATUS_UNKNOWN
;
3048 conv
= get_unformatted_convert (dtp
->common
.unit
);
3050 if (conv
== GFC_CONVERT_NONE
)
3051 conv
= compile_options
.convert
;
3053 u_flags
.convert
= 0;
3055 #ifdef HAVE_GFC_REAL_17
3056 u_flags
.convert
= conv
& (GFC_CONVERT_R16_IEEE
| GFC_CONVERT_R16_IBM
);
3057 conv
&= ~(GFC_CONVERT_R16_IEEE
| GFC_CONVERT_R16_IBM
);
3062 case GFC_CONVERT_NATIVE
:
3063 case GFC_CONVERT_SWAP
:
3066 case GFC_CONVERT_BIG
:
3067 conv
= __BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
3070 case GFC_CONVERT_LITTLE
:
3071 conv
= __BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
3075 internal_error (&opp
.common
, "Illegal value for CONVERT");
3079 u_flags
.convert
|= conv
;
3081 opp
.common
= dtp
->common
;
3082 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
3083 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
3084 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
3085 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
3086 if (dtp
->u
.p
.current_unit
== NULL
)
3090 if (dtp
->u
.p
.current_unit
->child_dtio
== 0)
3092 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
3094 dtp
->u
.p
.current_unit
->has_size
= true;
3095 /* Initialize the count. */
3096 dtp
->u
.p
.current_unit
->size_used
= 0;
3099 dtp
->u
.p
.current_unit
->has_size
= false;
3101 else if (dtp
->u
.p
.current_unit
->internal_unit_kind
> 0)
3102 dtp
->u
.p
.unit_is_internal
= 1;
3104 if ((cf
& IOPARM_DT_HAS_ASYNCHRONOUS
) != 0)
3107 f
= find_option (&dtp
->common
, dtp
->asynchronous
, dtp
->asynchronous_len
,
3108 async_opt
, "Bad ASYNCHRONOUS in data transfer "
3110 if (f
== ASYNC_YES
&& dtp
->u
.p
.current_unit
->flags
.async
!= ASYNC_YES
)
3112 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3113 "ASYNCHRONOUS transfer without "
3114 "ASYHCRONOUS='YES' in OPEN");
3117 dtp
->u
.p
.async
= f
== ASYNC_YES
;
3120 au
= dtp
->u
.p
.current_unit
->au
;
3125 /* If this is an asynchronous I/O statement, collect errors and
3126 return if there are any. */
3127 if (collect_async_errors (&dtp
->common
, au
))
3132 /* Synchronous statement: Perform a wait operation for any pending
3133 asynchronous I/O. This needs to be done before all other error
3134 checks. See F2008, 9.6.4.1. */
3135 if (async_wait (&(dtp
->common
), au
))
3140 /* Check the action. */
3142 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
3144 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
3145 "Cannot read from file opened for WRITE");
3149 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
3151 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
3152 "Cannot write to file opened for READ");
3156 dtp
->u
.p
.first_item
= 1;
3158 /* Check the format. */
3160 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
3163 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
3164 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
3167 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3168 "Format present for UNFORMATTED data transfer");
3172 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
3174 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
3176 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3177 "A format cannot be specified with a namelist");
3181 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
3182 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
3184 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3185 "Missing format for FORMATTED data transfer");
3189 if (is_internal_unit (dtp
)
3190 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3192 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3193 "Internal file cannot be accessed by UNFORMATTED "
3198 /* Check the record or position number. */
3200 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
3201 && (cf
& IOPARM_DT_HAS_REC
) == 0)
3203 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
3204 "Direct access data transfer requires record number");
3208 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3210 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
3212 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3213 "Record number not allowed for sequential access "
3218 if (compile_options
.warn_std
&&
3219 dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
)
3221 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3222 "Sequential READ or WRITE not allowed after "
3223 "EOF marker, possibly use REWIND or BACKSPACE");
3228 /* Process the ADVANCE option. */
3230 dtp
->u
.p
.advance_status
3231 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
3232 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
3233 "Bad ADVANCE parameter in data transfer statement");
3235 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
3237 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3239 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3240 "ADVANCE specification conflicts with sequential "
3245 if (is_internal_unit (dtp
))
3247 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3248 "ADVANCE specification conflicts with internal file");
3252 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
3253 != IOPARM_DT_HAS_FORMAT
)
3255 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3256 "ADVANCE specification requires an explicit format");
3261 /* Child IO is non-advancing and any ADVANCE= specifier is ignored.
3263 if (dtp
->u
.p
.current_unit
->child_dtio
> 0)
3264 dtp
->u
.p
.advance_status
= ADVANCE_NO
;
3268 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
3270 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3272 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
3273 "EOR specification requires an ADVANCE specification "
3278 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
3279 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3281 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
3282 "SIZE specification requires an ADVANCE "
3283 "specification of NO");
3288 { /* Write constraints. */
3289 if ((cf
& IOPARM_END
) != 0)
3291 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3292 "END specification cannot appear in a write "
3297 if ((cf
& IOPARM_EOR
) != 0)
3299 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3300 "EOR specification cannot appear in a write "
3305 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
3307 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3308 "SIZE specification cannot appear in a write "
3314 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
3315 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
3317 /* Check the decimal mode. */
3318 dtp
->u
.p
.current_unit
->decimal_status
3319 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
3320 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
3321 decimal_opt
, "Bad DECIMAL parameter in data transfer "
3324 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
3325 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
3327 /* Check the round mode. */
3328 dtp
->u
.p
.current_unit
->round_status
3329 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
3330 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
3331 round_opt
, "Bad ROUND parameter in data transfer "
3334 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
3335 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
3337 /* Check the sign mode. */
3338 dtp
->u
.p
.sign_status
3339 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
3340 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
3341 "Bad SIGN parameter in data transfer statement");
3343 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
3344 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
3346 /* Check the blank mode. */
3347 dtp
->u
.p
.blank_status
3348 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
3349 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
3351 "Bad BLANK parameter in data transfer statement");
3353 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
3354 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
3356 /* Check the delim mode. */
3357 dtp
->u
.p
.current_unit
->delim_status
3358 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
3359 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
3360 delim_opt
, "Bad DELIM parameter in data transfer statement");
3362 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
3364 if (ionml
&& dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_UNSPECIFIED
)
3365 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
3367 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
3370 /* Check the pad mode. */
3371 dtp
->u
.p
.current_unit
->pad_status
3372 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
3373 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
3374 "Bad PAD parameter in data transfer statement");
3376 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
3377 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
3379 /* Set up the subroutine that will handle the transfers. */
3383 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3384 dtp
->u
.p
.transfer
= unformatted_read
;
3387 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3388 dtp
->u
.p
.transfer
= list_formatted_read
;
3390 dtp
->u
.p
.transfer
= formatted_transfer
;
3395 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3396 dtp
->u
.p
.transfer
= unformatted_write
;
3399 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3400 dtp
->u
.p
.transfer
= list_formatted_write
;
3402 dtp
->u
.p
.transfer
= formatted_transfer
;
3406 if (au
&& dtp
->u
.p
.async
)
3408 NOTE ("enqueue_data_transfer");
3409 enqueue_data_transfer_init (au
, dtp
, read_flag
);
3413 NOTE ("invoking data_transfer_init_worker");
3414 data_transfer_init_worker (dtp
, read_flag
);
3419 data_transfer_init_worker (st_parameter_dt
*dtp
, int read_flag
)
3421 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3423 NOTE ("starting worker...");
3425 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.form
!= FORM_UNFORMATTED
3426 && ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3427 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
3428 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
3430 /* Check to see if we might be reading what we wrote before */
3432 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
3433 && !is_internal_unit (dtp
))
3435 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
3437 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
3438 sflush(dtp
->u
.p
.current_unit
->s
);
3441 /* Check the POS= specifier: that it is in range and that it is used with a
3442 unit that has been connected for STREAM access. F2003 9.5.1.10. */
3444 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
3446 if (is_stream_io (dtp
))
3451 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3452 "POS=specifier must be positive");
3456 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
3458 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3459 "POS=specifier too large");
3463 dtp
->rec
= dtp
->pos
;
3465 if (dtp
->u
.p
.mode
== READING
)
3467 /* Reset the endfile flag; if we hit EOF during reading
3468 we'll set the flag and generate an error at that point
3469 rather than worrying about it here. */
3470 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
3473 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
3475 fbuf_reset (dtp
->u
.p
.current_unit
);
3476 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1,
3479 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3482 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
3487 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3488 "POS=specifier not allowed, "
3489 "Try OPEN with ACCESS='stream'");
3495 /* Sanity checks on the record number. */
3496 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
3500 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3501 "Record number must be positive");
3505 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
3507 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3508 "Record number too large");
3512 /* Make sure format buffer is reset. */
3513 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3514 fbuf_reset (dtp
->u
.p
.current_unit
);
3517 /* Check whether the record exists to be read. Only
3518 a partial record needs to exist. */
3520 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
3521 * dtp
->u
.p
.current_unit
->recl
>= ssize (dtp
->u
.p
.current_unit
->s
))
3523 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3524 "Non-existing record number");
3528 /* Position the file. */
3529 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
3530 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
3532 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3536 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
3538 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3539 "Record number not allowed for stream access "
3545 /* Bugware for badly written mixed C-Fortran I/O. */
3546 if (!is_internal_unit (dtp
))
3547 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
3549 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
3551 /* Set the maximum position reached from the previous I/O operation. This
3552 could be greater than zero from a previous non-advancing write. */
3553 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
3557 /* Make sure that we don't do a read after a nonadvancing write. */
3561 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
3563 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3564 "Cannot READ after a nonadvancing WRITE");
3570 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
3571 dtp
->u
.p
.current_unit
->read_bad
= 1;
3574 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3576 #ifdef HAVE_POSIX_2008_LOCALE
3577 dtp
->u
.p
.old_locale
= uselocale (c_locale
);
3579 __gthread_mutex_lock (&old_locale_lock
);
3580 if (!old_locale_ctr
++)
3582 old_locale
= setlocale (LC_NUMERIC
, NULL
);
3583 setlocale (LC_NUMERIC
, "C");
3585 __gthread_mutex_unlock (&old_locale_lock
);
3587 /* Start the data transfer if we are doing a formatted transfer. */
3588 if ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0
3589 && dtp
->u
.p
.ionml
== NULL
)
3590 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
3595 /* Initialize an array_loop_spec given the array descriptor. The function
3596 returns the index of the last element of the array, and also returns
3597 starting record, where the first I/O goes to (necessary in case of
3598 negative strides). */
3601 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
3602 gfc_offset
*start_record
)
3604 int rank
= GFC_DESCRIPTOR_RANK(desc
);
3613 for (i
=0; i
<rank
; i
++)
3615 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3616 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3617 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
3618 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
3619 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
3620 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
3622 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
3624 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3625 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3629 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3630 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3631 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3632 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3642 /* Determine the index to the next record in an internal unit array by
3643 by incrementing through the array_loop_spec. */
3646 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
3654 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
3659 if (ls
[i
].idx
> ls
[i
].end
)
3661 ls
[i
].idx
= ls
[i
].start
;
3667 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
3677 /* Skip to the end of the current record, taking care of an optional
3678 record marker of size bytes. If the file is not seekable, we
3679 read chunks of size MAX_READ until we get to the right
3683 skip_record (st_parameter_dt
*dtp
, gfc_offset bytes
)
3685 ssize_t rlength
, readb
;
3686 #define MAX_READ 4096
3689 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
3690 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
3693 /* Direct access files do not generate END conditions,
3695 if (sseek (dtp
->u
.p
.current_unit
->s
,
3696 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
3698 /* Seeking failed, fall back to seeking by reading data. */
3699 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
3702 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
3703 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3705 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
3708 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3712 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
3716 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= 0;
3720 /* Advance to the next record reading unformatted files, taking
3721 care of subrecords. If complete_record is nonzero, we loop
3722 until all subrecords are cleared. */
3725 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
3729 bytes
= compile_options
.record_marker
== 0 ?
3730 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
3735 /* Skip over tail */
3737 skip_record (dtp
, bytes
);
3739 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
3748 min_off (gfc_offset a
, gfc_offset b
)
3750 return (a
< b
? a
: b
);
3754 /* Space to the next record for read mode. */
3757 next_record_r (st_parameter_dt
*dtp
, int done
)
3763 switch (current_mode (dtp
))
3765 /* No records in unformatted STREAM I/O. */
3766 case UNFORMATTED_STREAM
:
3769 case UNFORMATTED_SEQUENTIAL
:
3770 next_record_r_unf (dtp
, 1);
3771 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3774 case FORMATTED_DIRECT
:
3775 case UNFORMATTED_DIRECT
:
3776 skip_record (dtp
, dtp
->u
.p
.current_unit
->bytes_left
);
3779 case FORMATTED_STREAM
:
3780 case FORMATTED_SEQUENTIAL
:
3781 /* read_sf has already terminated input because of an '\n', or
3783 if (dtp
->u
.p
.sf_seen_eor
)
3785 dtp
->u
.p
.sf_seen_eor
= 0;
3789 if (is_internal_unit (dtp
))
3791 if (is_array_io (dtp
))
3795 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3797 if (!done
&& finished
)
3800 /* Now seek to this record. */
3801 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3802 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3804 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3807 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3811 gfc_offset bytes_left
= dtp
->u
.p
.current_unit
->bytes_left
;
3812 bytes_left
= min_off (bytes_left
,
3813 ssize (dtp
->u
.p
.current_unit
->s
)
3814 - stell (dtp
->u
.p
.current_unit
->s
));
3815 if (sseek (dtp
->u
.p
.current_unit
->s
,
3816 bytes_left
, SEEK_CUR
) < 0)
3818 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3821 dtp
->u
.p
.current_unit
->bytes_left
3822 = dtp
->u
.p
.current_unit
->recl
;
3826 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
3831 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
3835 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3838 if (is_stream_io (dtp
)
3839 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
3840 || dtp
->u
.p
.current_unit
->bytes_left
3841 == dtp
->u
.p
.current_unit
->recl
)
3847 if (is_stream_io (dtp
))
3848 dtp
->u
.p
.current_unit
->strm_pos
++;
3855 case FORMATTED_UNSPECIFIED
:
3861 /* Small utility function to write a record marker, taking care of
3862 byte swapping and of choosing the correct size. */
3865 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
3871 if (compile_options
.record_marker
== 0)
3872 len
= sizeof (GFC_INTEGER_4
);
3874 len
= compile_options
.record_marker
;
3876 int convert
= dtp
->u
.p
.current_unit
->flags
.convert
;
3877 #ifdef HAVE_GFC_REAL_17
3878 convert
&= ~(GFC_CONVERT_R16_IEEE
| GFC_CONVERT_R16_IBM
);
3880 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
3881 if (likely (convert
== GFC_CONVERT_NATIVE
))
3885 case sizeof (GFC_INTEGER_4
):
3887 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
3890 case sizeof (GFC_INTEGER_8
):
3892 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
3896 runtime_error ("Illegal value for record marker");
3906 case sizeof (GFC_INTEGER_4
):
3908 memcpy (&u32
, &buf4
, sizeof (u32
));
3909 u32
= __builtin_bswap32 (u32
);
3910 return swrite (dtp
->u
.p
.current_unit
->s
, &u32
, len
);
3913 case sizeof (GFC_INTEGER_8
):
3915 memcpy (&u64
, &buf8
, sizeof (u64
));
3916 u64
= __builtin_bswap64 (u64
);
3917 return swrite (dtp
->u
.p
.current_unit
->s
, &u64
, len
);
3921 runtime_error ("Illegal value for record marker");
3928 /* Position to the next (sub)record in write mode for
3929 unformatted sequential files. */
3932 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
3934 gfc_offset m
, m_write
, record_marker
;
3936 /* Bytes written. */
3937 m
= dtp
->u
.p
.current_unit
->recl_subrecord
3938 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3940 if (compile_options
.record_marker
== 0)
3941 record_marker
= sizeof (GFC_INTEGER_4
);
3943 record_marker
= compile_options
.record_marker
;
3945 /* Seek to the head and overwrite the bogus length with the real
3948 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- record_marker
,
3957 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3960 /* Seek past the end of the current record. */
3962 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
, SEEK_CUR
) < 0))
3965 /* Write the length tail. If we finish a record containing
3966 subrecords, we write out the negative length. */
3968 if (dtp
->u
.p
.current_unit
->continued
)
3973 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3979 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3985 /* Utility function like memset() but operating on streams. Return
3986 value is same as for POSIX write(). */
3989 sset (stream
*s
, int c
, gfc_offset nbyte
)
3991 #define WRITE_CHUNK 256
3992 char p
[WRITE_CHUNK
];
3993 gfc_offset bytes_left
;
3996 if (nbyte
< WRITE_CHUNK
)
3997 memset (p
, c
, nbyte
);
3999 memset (p
, c
, WRITE_CHUNK
);
4002 while (bytes_left
> 0)
4004 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
4005 trans
= swrite (s
, p
, trans
);
4008 bytes_left
-= trans
;
4011 return nbyte
- bytes_left
;
4015 /* Finish up a record according to the legacy carriagecontrol type, based
4016 on the first character in the record. */
4019 next_record_cc (st_parameter_dt
*dtp
)
4021 /* Only valid with CARRIAGECONTROL=FORTRAN. */
4022 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
4025 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
4026 if (dtp
->u
.p
.cc
.len
> 0)
4028 char *p
= fbuf_alloc (dtp
->u
.p
.current_unit
, dtp
->u
.p
.cc
.len
);
4030 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
4032 /* Output CR for the first character with default CC setting. */
4033 *(p
++) = dtp
->u
.p
.cc
.u
.end
;
4034 if (dtp
->u
.p
.cc
.len
> 1)
4035 *p
= dtp
->u
.p
.cc
.u
.end
;
4039 /* Position to the next record in write mode. */
4042 next_record_w (st_parameter_dt
*dtp
, int done
)
4044 gfc_offset max_pos_off
;
4046 /* Zero counters for X- and T-editing. */
4047 max_pos_off
= dtp
->u
.p
.max_pos
;
4048 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
4050 switch (current_mode (dtp
))
4052 /* No records in unformatted STREAM I/O. */
4053 case UNFORMATTED_STREAM
:
4056 case FORMATTED_DIRECT
:
4057 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
4060 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
4061 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
4062 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
4063 dtp
->u
.p
.current_unit
->bytes_left
)
4064 != dtp
->u
.p
.current_unit
->bytes_left
)
4069 case UNFORMATTED_DIRECT
:
4070 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
4072 gfc_offset length
= dtp
->u
.p
.current_unit
->bytes_left
;
4073 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
4078 case UNFORMATTED_SEQUENTIAL
:
4079 next_record_w_unf (dtp
, 0);
4080 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
4083 case FORMATTED_STREAM
:
4084 case FORMATTED_SEQUENTIAL
:
4086 if (is_internal_unit (dtp
))
4089 /* Internal unit, so must fit in memory. */
4091 size_t max_pos
= max_pos_off
;
4092 if (is_array_io (dtp
))
4096 length
= dtp
->u
.p
.current_unit
->bytes_left
;
4098 /* If the farthest position reached is greater than current
4099 position, adjust the position and set length to pad out
4100 whats left. Otherwise just pad whats left.
4101 (for character array unit) */
4102 m
= dtp
->u
.p
.current_unit
->recl
4103 - dtp
->u
.p
.current_unit
->bytes_left
;
4106 length
= (max_pos
- m
);
4107 if (sseek (dtp
->u
.p
.current_unit
->s
,
4108 length
, SEEK_CUR
) < 0)
4110 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
4113 length
= ((size_t) dtp
->u
.p
.current_unit
->recl
- max_pos
);
4116 p
= write_block (dtp
, length
);
4120 if (unlikely (is_char4_unit (dtp
)))
4122 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
4123 memset4 (p4
, ' ', length
);
4126 memset (p
, ' ', length
);
4128 /* Now that the current record has been padded out,
4129 determine where the next record in the array is.
4130 Note that this can return a negative value, so it
4131 needs to be assigned to a signed value. */
4132 gfc_offset record
= next_array_record
4133 (dtp
, dtp
->u
.p
.current_unit
->ls
, &finished
);
4135 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4137 /* Now seek to this record */
4138 record
= record
* dtp
->u
.p
.current_unit
->recl
;
4140 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
4142 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
4146 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
4152 /* If this is the last call to next_record move to the farthest
4153 position reached and set length to pad out the remainder
4154 of the record. (for character scaler unit) */
4157 m
= dtp
->u
.p
.current_unit
->recl
4158 - dtp
->u
.p
.current_unit
->bytes_left
;
4161 length
= max_pos
- m
;
4162 if (sseek (dtp
->u
.p
.current_unit
->s
,
4163 length
, SEEK_CUR
) < 0)
4165 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
4168 length
= (size_t) dtp
->u
.p
.current_unit
->recl
4172 length
= dtp
->u
.p
.current_unit
->bytes_left
;
4176 p
= write_block (dtp
, length
);
4180 if (unlikely (is_char4_unit (dtp
)))
4182 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
4183 memset4 (p4
, (gfc_char4_t
) ' ', length
);
4186 memset (p
, ' ', length
);
4190 else if (dtp
->u
.p
.seen_dollar
== 1)
4192 /* Handle legacy CARRIAGECONTROL line endings. */
4193 else if (dtp
->u
.p
.current_unit
->flags
.cc
== CC_FORTRAN
)
4194 next_record_cc (dtp
);
4197 /* Skip newlines for CC=CC_NONE. */
4198 const int len
= (dtp
->u
.p
.current_unit
->flags
.cc
== CC_NONE
)
4205 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
4206 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
4208 char *p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
4216 if (is_stream_io (dtp
))
4218 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
4219 if (dtp
->u
.p
.current_unit
->strm_pos
4220 < ssize (dtp
->u
.p
.current_unit
->s
))
4221 unit_truncate (dtp
->u
.p
.current_unit
,
4222 dtp
->u
.p
.current_unit
->strm_pos
- 1,
4228 case FORMATTED_UNSPECIFIED
:
4232 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
4237 /* Position to the next record, which means moving to the end of the
4238 current record. This can happen under several different
4239 conditions. If the done flag is not set, we get ready to process
4243 next_record (st_parameter_dt
*dtp
, int done
)
4245 gfc_offset fp
; /* File position. */
4247 dtp
->u
.p
.current_unit
->read_bad
= 0;
4249 if (dtp
->u
.p
.mode
== READING
)
4250 next_record_r (dtp
, done
);
4252 next_record_w (dtp
, done
);
4254 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
4256 if (!is_stream_io (dtp
))
4258 /* Since we have changed the position, set it to unspecified so
4259 that INQUIRE(POSITION=) knows it needs to look into it. */
4261 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_UNSPECIFIED
;
4263 dtp
->u
.p
.current_unit
->current_record
= 0;
4264 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
4266 fp
= stell (dtp
->u
.p
.current_unit
->s
);
4267 /* Calculate next record, rounding up partial records. */
4268 dtp
->u
.p
.current_unit
->last_record
=
4269 (fp
+ dtp
->u
.p
.current_unit
->recl
) /
4270 dtp
->u
.p
.current_unit
->recl
- 1;
4273 dtp
->u
.p
.current_unit
->last_record
++;
4279 smarkeor (dtp
->u
.p
.current_unit
->s
);
4283 /* Finalize the current data transfer. For a nonadvancing transfer,
4284 this means advancing to the next record. For internal units close the
4285 stream associated with the unit. */
4288 finalize_transfer (st_parameter_dt
*dtp
)
4290 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
4292 if ((dtp
->u
.p
.ionml
!= NULL
)
4293 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
4295 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
4297 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
4298 "Namelist formatting for unit connected "
4299 "with FORM='UNFORMATTED'");
4303 dtp
->u
.p
.namelist_mode
= 1;
4304 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
4305 namelist_read (dtp
);
4307 namelist_write (dtp
);
4310 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
4311 *dtp
->size
= dtp
->u
.p
.current_unit
->size_used
;
4313 if (dtp
->u
.p
.eor_condition
)
4315 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
4319 if (dtp
->u
.p
.current_unit
&& (dtp
->u
.p
.current_unit
->child_dtio
> 0))
4321 if (cf
& IOPARM_DT_HAS_FORMAT
)
4323 free (dtp
->u
.p
.fmt
);
4329 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
4331 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
4332 dtp
->u
.p
.current_unit
->current_record
= 0;
4336 dtp
->u
.p
.transfer
= NULL
;
4337 if (dtp
->u
.p
.current_unit
== NULL
)
4340 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
4342 finish_list_read (dtp
);
4346 if (dtp
->u
.p
.mode
== WRITING
)
4347 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
4348 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
4350 if (is_stream_io (dtp
))
4352 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
4353 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
4354 next_record (dtp
, 1);
4359 dtp
->u
.p
.current_unit
->current_record
= 0;
4361 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
4363 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
4364 dtp
->u
.p
.seen_dollar
= 0;
4368 /* For non-advancing I/O, save the current maximum position for use in the
4369 next I/O operation if needed. */
4370 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
4372 if (dtp
->u
.p
.skips
> 0)
4375 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
4376 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
4377 - dtp
->u
.p
.current_unit
->bytes_left
);
4379 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
4382 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
4383 - dtp
->u
.p
.current_unit
->bytes_left
);
4384 dtp
->u
.p
.current_unit
->saved_pos
=
4385 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
4386 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
4389 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
4390 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
4391 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
4393 dtp
->u
.p
.current_unit
->saved_pos
= 0;
4394 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
4395 next_record (dtp
, 1);
4399 if (dtp
->u
.p
.unit_is_internal
)
4401 /* The unit structure may be reused later so clear the
4402 internal unit kind. */
4403 dtp
->u
.p
.current_unit
->internal_unit_kind
= 0;
4405 fbuf_destroy (dtp
->u
.p
.current_unit
);
4406 if (dtp
->u
.p
.current_unit
4407 && (dtp
->u
.p
.current_unit
->child_dtio
== 0)
4408 && dtp
->u
.p
.current_unit
->s
)
4410 sclose (dtp
->u
.p
.current_unit
->s
);
4411 dtp
->u
.p
.current_unit
->s
= NULL
;
4415 #ifdef HAVE_POSIX_2008_LOCALE
4416 if (dtp
->u
.p
.old_locale
!= (locale_t
) 0)
4418 uselocale (dtp
->u
.p
.old_locale
);
4419 dtp
->u
.p
.old_locale
= (locale_t
) 0;
4422 __gthread_mutex_lock (&old_locale_lock
);
4423 if (!--old_locale_ctr
)
4425 setlocale (LC_NUMERIC
, old_locale
);
4428 __gthread_mutex_unlock (&old_locale_lock
);
4432 /* Transfer function for IOLENGTH. It doesn't actually do any
4433 data transfer, it just updates the length counter. */
4436 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
4437 void *dest
__attribute__ ((unused
)),
4438 int kind
__attribute__((unused
)),
4439 size_t size
, size_t nelems
)
4441 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
4442 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
4446 /* Initialize the IOLENGTH data transfer. This function is in essence
4447 a very much simplified version of data_transfer_init(), because it
4448 doesn't have to deal with units at all. */
4451 iolength_transfer_init (st_parameter_dt
*dtp
)
4453 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
4456 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
4458 /* Set up the subroutine that will handle the transfers. */
4460 dtp
->u
.p
.transfer
= iolength_transfer
;
4464 /* Library entry point for the IOLENGTH form of the INQUIRE
4465 statement. The IOLENGTH form requires no I/O to be performed, but
4466 it must still be a runtime library call so that we can determine
4467 the iolength for dynamic arrays and such. */
4469 extern void st_iolength (st_parameter_dt
*);
4470 export_proto(st_iolength
);
4473 st_iolength (st_parameter_dt
*dtp
)
4475 library_start (&dtp
->common
);
4476 iolength_transfer_init (dtp
);
4479 extern void st_iolength_done (st_parameter_dt
*);
4480 export_proto(st_iolength_done
);
4483 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
4490 /* The READ statement. */
4492 extern void st_read (st_parameter_dt
*);
4493 export_proto(st_read
);
4496 st_read (st_parameter_dt
*dtp
)
4498 library_start (&dtp
->common
);
4500 data_transfer_init (dtp
, 1);
4503 extern void st_read_done (st_parameter_dt
*);
4504 export_proto(st_read_done
);
4507 st_read_done_worker (st_parameter_dt
*dtp
, bool unlock
)
4509 bool free_newunit
= false;
4510 finalize_transfer (dtp
);
4514 /* If this is a parent READ statement we do not need to retain the
4515 internal unit structure for child use. */
4516 if (dtp
->u
.p
.current_unit
!= NULL
4517 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4519 if (dtp
->u
.p
.unit_is_internal
)
4521 if ((dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4523 free (dtp
->u
.p
.current_unit
->filename
);
4524 dtp
->u
.p
.current_unit
->filename
= NULL
;
4525 free (dtp
->u
.p
.current_unit
->ls
);
4526 dtp
->u
.p
.current_unit
->ls
= NULL
;
4528 free_newunit
= true;
4530 if (dtp
->u
.p
.unit_is_internal
|| dtp
->u
.p
.format_not_saved
)
4532 free_format_data (dtp
->u
.p
.fmt
);
4537 unlock_unit (dtp
->u
.p
.current_unit
);
4540 /* Avoid inverse lock issues by placing after unlock_unit. */
4542 newunit_free (dtp
->common
.unit
);
4543 UNLOCK (&unit_lock
);
4548 st_read_done (st_parameter_dt
*dtp
)
4550 if (dtp
->u
.p
.current_unit
)
4552 if (dtp
->u
.p
.current_unit
->au
)
4554 if (dtp
->common
.flags
& IOPARM_DT_HAS_ID
)
4555 *dtp
->id
= enqueue_done_id (dtp
->u
.p
.current_unit
->au
, AIO_READ_DONE
);
4559 enqueue_done (dtp
->u
.p
.current_unit
->au
, AIO_READ_DONE
);
4561 unlock_unit (dtp
->u
.p
.current_unit
);
4564 st_read_done_worker (dtp
, true); /* Calls unlock_unit. */
4570 extern void st_write (st_parameter_dt
*);
4571 export_proto (st_write
);
4574 st_write (st_parameter_dt
*dtp
)
4576 library_start (&dtp
->common
);
4577 data_transfer_init (dtp
, 0);
4582 st_write_done_worker (st_parameter_dt
*dtp
, bool unlock
)
4584 bool free_newunit
= false;
4585 finalize_transfer (dtp
);
4587 if (dtp
->u
.p
.current_unit
!= NULL
4588 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4590 /* Deal with endfile conditions associated with sequential files. */
4591 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4592 switch (dtp
->u
.p
.current_unit
->endfile
)
4594 case AT_ENDFILE
: /* Remain at the endfile record. */
4598 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
4602 /* Get rid of whatever is after this record. */
4603 if (!is_internal_unit (dtp
))
4604 unit_truncate (dtp
->u
.p
.current_unit
,
4605 stell (dtp
->u
.p
.current_unit
->s
),
4607 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4613 /* If this is a parent WRITE statement we do not need to retain the
4614 internal unit structure for child use. */
4615 if (dtp
->u
.p
.unit_is_internal
)
4617 if ((dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4619 free (dtp
->u
.p
.current_unit
->filename
);
4620 dtp
->u
.p
.current_unit
->filename
= NULL
;
4621 free (dtp
->u
.p
.current_unit
->ls
);
4622 dtp
->u
.p
.current_unit
->ls
= NULL
;
4624 free_newunit
= true;
4626 if (dtp
->u
.p
.unit_is_internal
|| dtp
->u
.p
.format_not_saved
)
4628 free_format_data (dtp
->u
.p
.fmt
);
4633 unlock_unit (dtp
->u
.p
.current_unit
);
4636 /* Avoid inverse lock issues by placing after unlock_unit. */
4638 newunit_free (dtp
->common
.unit
);
4639 UNLOCK (&unit_lock
);
4643 extern void st_write_done (st_parameter_dt
*);
4644 export_proto(st_write_done
);
4647 st_write_done (st_parameter_dt
*dtp
)
4649 if (dtp
->u
.p
.current_unit
)
4651 if (dtp
->u
.p
.current_unit
->au
&& dtp
->u
.p
.async
)
4653 if (dtp
->common
.flags
& IOPARM_DT_HAS_ID
)
4654 *dtp
->id
= enqueue_done_id (dtp
->u
.p
.current_unit
->au
,
4658 /* We perform synchronous I/O on an asynchronous unit, so no need
4659 to enqueue AIO_READ_DONE. */
4661 enqueue_done (dtp
->u
.p
.current_unit
->au
, AIO_WRITE_DONE
);
4663 unlock_unit (dtp
->u
.p
.current_unit
);
4666 st_write_done_worker (dtp
, true); /* Calls unlock_unit. */
4672 /* Wait operation. We need to keep around the do-nothing version
4673 of st_wait for compatibility with previous versions, which had marked
4674 the argument as unused (and thus liable to be removed).
4676 TODO: remove at next bump in version number. */
4679 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
4685 st_wait_async (st_parameter_wait
*wtp
)
4687 gfc_unit
*u
= find_unit (wtp
->common
.unit
);
4688 if (ASYNC_IO
&& u
&& u
->au
)
4690 if (wtp
->common
.flags
& IOPARM_WAIT_HAS_ID
)
4691 async_wait_id (&(wtp
->common
), u
->au
, *wtp
->id
);
4693 async_wait (&(wtp
->common
), u
->au
);
4700 /* Receives the scalar information for namelist objects and stores it
4701 in a linked list of namelist_info types. */
4704 set_nml_var (st_parameter_dt
*dtp
, void *var_addr
, char *var_name
,
4705 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4706 dtype_type dtype
, void *dtio_sub
, void *vtable
)
4708 namelist_info
*t1
= NULL
;
4710 size_t var_name_len
= strlen (var_name
);
4712 nml
= (namelist_info
*) xmalloc (sizeof (namelist_info
));
4714 nml
->mem_pos
= var_addr
;
4715 nml
->dtio_sub
= dtio_sub
;
4716 nml
->vtable
= vtable
;
4718 nml
->var_name
= (char*) xmalloc (var_name_len
+ 1);
4719 memcpy (nml
->var_name
, var_name
, var_name_len
);
4720 nml
->var_name
[var_name_len
] = '\0';
4722 nml
->len
= (int) len
;
4723 nml
->string_length
= (index_type
) string_length
;
4725 nml
->var_rank
= (int) (dtype
.rank
);
4726 nml
->size
= (index_type
) (dtype
.elem_len
);
4727 nml
->type
= (bt
) (dtype
.type
);
4729 if (nml
->var_rank
> 0)
4731 nml
->dim
= (descriptor_dimension
*)
4732 xmallocarray (nml
->var_rank
, sizeof (descriptor_dimension
));
4733 nml
->ls
= (array_loop_spec
*)
4734 xmallocarray (nml
->var_rank
, sizeof (array_loop_spec
));
4744 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
4746 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
4747 dtp
->u
.p
.ionml
= nml
;
4751 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
4756 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
4757 GFC_INTEGER_4
, gfc_charlen_type
, dtype_type
);
4758 export_proto(st_set_nml_var
);
4761 st_set_nml_var (st_parameter_dt
*dtp
, void *var_addr
, char *var_name
,
4762 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4765 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4770 /* Essentially the same as previous but carrying the dtio procedure
4771 and the vtable as additional arguments. */
4772 extern void st_set_nml_dtio_var (st_parameter_dt
*dtp
, void *, char *,
4773 GFC_INTEGER_4
, gfc_charlen_type
, dtype_type
,
4775 export_proto(st_set_nml_dtio_var
);
4779 st_set_nml_dtio_var (st_parameter_dt
*dtp
, void *var_addr
, char *var_name
,
4780 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4781 dtype_type dtype
, void *dtio_sub
, void *vtable
)
4783 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4784 dtype
, dtio_sub
, vtable
);
4787 /* Store the dimensional information for the namelist object. */
4788 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
4789 index_type
, index_type
,
4791 export_proto(st_set_nml_var_dim
);
4794 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
4795 index_type stride
, index_type lbound
,
4803 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
4805 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
4809 /* Once upon a time, a poor innocent Fortran program was reading a
4810 file, when suddenly it hit the end-of-file (EOF). Unfortunately
4811 the OS doesn't tell whether we're at the EOF or whether we already
4812 went past it. Luckily our hero, libgfortran, keeps track of this.
4813 Call this function when you detect an EOF condition. See Section
4817 hit_eof (st_parameter_dt
*dtp
)
4819 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
4821 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4822 switch (dtp
->u
.p
.current_unit
->endfile
)
4826 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4827 if (!is_internal_unit (dtp
) && !dtp
->u
.p
.namelist_mode
)
4829 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
4830 dtp
->u
.p
.current_unit
->current_record
= 0;
4833 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4837 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
4838 dtp
->u
.p
.current_unit
->current_record
= 0;
4843 /* Non-sequential files don't have an ENDFILE record, so we
4844 can't be at AFTER_ENDFILE. */
4845 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4846 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4847 dtp
->u
.p
.current_unit
->current_record
= 0;