1 /* Copyright (C) 2002-2024 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 GFC_INTEGER_4 unit
= dtp
->u
.p
.current_unit
->unit_number
;
1096 char tmp_iomsg
[IOMSG_LEN
] = "";
1098 gfc_charlen_type child_iomsg_len
;
1099 GFC_INTEGER_4 noiostat
;
1100 GFC_INTEGER_4
*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
.child_saved_iostat
= *child_iostat
;
1124 dtp
->u
.p
.current_unit
->child_dtio
--;
1126 if ((dtp
->u
.p
.child_saved_iostat
!= 0) &&
1127 !(dtp
->common
.flags
& IOPARM_HAS_IOMSG
) &&
1128 !(dtp
->common
.flags
& IOPARM_HAS_IOSTAT
))
1130 char message
[IOMSG_LEN
+ 1];
1131 child_iomsg_len
= string_len_trim (IOMSG_LEN
, child_iomsg
);
1132 fstrcpy (message
, child_iomsg_len
, child_iomsg
, child_iomsg_len
);
1133 message
[child_iomsg_len
] = '\0';
1134 generate_error (&dtp
->common
, dtp
->u
.p
.child_saved_iostat
,
1141 if (type
== BT_CHARACTER
)
1142 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
1143 read_block_direct (dtp
, dest
, size
* nelems
);
1145 convert
= dtp
->u
.p
.current_unit
->flags
.convert
;
1146 if (unlikely (convert
!= GFC_CONVERT_NATIVE
) && kind
!= 1)
1148 /* Handle wide chracters. */
1149 if (type
== BT_CHARACTER
)
1155 /* Break up complex into its constituent reals. */
1156 else if (type
== BT_COMPLEX
)
1161 #ifndef HAVE_GFC_REAL_17
1162 #if defined(HAVE_GFC_REAL_16) && GFC_REAL_16_DIGITS == 106
1163 /* IBM extended format is stored as a pair of IEEE754
1164 double values, with the more significant value first
1165 in both big and little endian. */
1166 if (kind
== 16 && (type
== BT_REAL
|| type
== BT_COMPLEX
))
1172 bswap_array (dest
, dest
, size
, nelems
);
1174 unit_convert bswap
= convert
& ~(GFC_CONVERT_R16_IEEE
| GFC_CONVERT_R16_IBM
);
1175 if (bswap
== GFC_CONVERT_SWAP
)
1177 if ((type
== BT_REAL
|| type
== BT_COMPLEX
)
1178 && ((kind
== 16 && (convert
& GFC_CONVERT_R16_IEEE
) == 0)
1179 || (kind
== 17 && (convert
& GFC_CONVERT_R16_IBM
))))
1180 bswap_array (dest
, dest
, size
/ 2, nelems
* 2);
1182 bswap_array (dest
, dest
, size
, nelems
);
1185 if ((convert
& GFC_CONVERT_R16_IEEE
)
1187 && (type
== BT_REAL
|| type
== BT_COMPLEX
))
1190 for (size_t i
= 0; i
< nelems
; i
++)
1194 memcpy (&r17
, pd
, 16);
1196 memcpy (pd
, &r16
, 16);
1200 else if ((dtp
->u
.p
.current_unit
->flags
.convert
& GFC_CONVERT_R16_IBM
)
1202 && (type
== BT_REAL
|| type
== BT_COMPLEX
))
1204 if (type
== BT_COMPLEX
&& size
== 32)
1211 for (size_t i
= 0; i
< nelems
; i
++)
1215 memcpy (&r16
, pd
, 16);
1217 memcpy (pd
, &r17
, 16);
1221 #endif /* HAVE_GFC_REAL_17. */
1226 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
1227 bytes on 64 bit machines. The unused bytes are not initialized and never
1228 used, which can show an error with memory checking analyzers like
1229 valgrind. We us BT_CLASS to denote a User Defined I/O call. */
1232 unformatted_write (st_parameter_dt
*dtp
, bt type
,
1233 void *source
, int kind
, size_t size
, size_t nelems
)
1235 unit_convert convert
;
1237 if (type
== BT_CLASS
)
1239 GFC_INTEGER_4 unit
= dtp
->u
.p
.current_unit
->unit_number
;
1240 char tmp_iomsg
[IOMSG_LEN
] = "";
1242 gfc_charlen_type child_iomsg_len
;
1243 GFC_INTEGER_4 noiostat
;
1244 GFC_INTEGER_4
*child_iostat
= NULL
;
1246 /* Set iostat, intent(out). */
1248 child_iostat
= ((dtp
->common
.flags
& IOPARM_HAS_IOSTAT
)
1249 ? dtp
->common
.iostat
: &noiostat
);
1251 /* Set iomsg, intent(inout). */
1252 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1254 child_iomsg
= dtp
->common
.iomsg
;
1255 child_iomsg_len
= dtp
->common
.iomsg_len
;
1259 child_iomsg
= tmp_iomsg
;
1260 child_iomsg_len
= IOMSG_LEN
;
1263 /* Call the user defined unformatted WRITE procedure. */
1264 dtp
->u
.p
.current_unit
->child_dtio
++;
1265 dtp
->u
.p
.ufdtio_ptr (source
, &unit
, child_iostat
, child_iomsg
,
1267 dtp
->u
.p
.child_saved_iostat
= *child_iostat
;
1268 dtp
->u
.p
.current_unit
->child_dtio
--;
1270 if ((dtp
->u
.p
.child_saved_iostat
!= 0) &&
1271 !(dtp
->common
.flags
& IOPARM_HAS_IOMSG
) &&
1272 !(dtp
->common
.flags
& IOPARM_HAS_IOSTAT
))
1274 char message
[IOMSG_LEN
+ 1];
1275 child_iomsg_len
= string_len_trim (IOMSG_LEN
, child_iomsg
);
1276 fstrcpy (message
, child_iomsg_len
, child_iomsg
, child_iomsg_len
);
1277 message
[child_iomsg_len
] = '\0';
1278 generate_error (&dtp
->common
, dtp
->u
.p
.child_saved_iostat
,
1284 convert
= dtp
->u
.p
.current_unit
->flags
.convert
;
1285 if (likely (convert
== GFC_CONVERT_NATIVE
) || kind
== 1
1286 #ifdef HAVE_GFC_REAL_17
1287 || ((type
== BT_REAL
|| type
== BT_COMPLEX
)
1288 && ((kind
== 16 && convert
== GFC_CONVERT_R16_IBM
)
1289 || (kind
== 17 && convert
== GFC_CONVERT_R16_IEEE
)))
1293 size_t stride
= type
== BT_CHARACTER
?
1294 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1296 write_buf (dtp
, source
, stride
* nelems
);
1300 #define BSWAP_BUFSZ 512
1301 char buffer
[BSWAP_BUFSZ
];
1307 /* Handle wide chracters. */
1308 if (type
== BT_CHARACTER
&& kind
!= 1)
1314 /* Break up complex into its constituent reals. */
1315 if (type
== BT_COMPLEX
)
1321 #if !defined(HAVE_GFC_REAL_17) && defined(HAVE_GFC_REAL_16) \
1322 && GFC_REAL_16_DIGITS == 106
1323 /* IBM extended format is stored as a pair of IEEE754
1324 double values, with the more significant value first
1325 in both big and little endian. */
1326 if (kind
== 16 && (type
== BT_REAL
|| type
== BT_COMPLEX
))
1333 /* By now, all complex variables have been split into their
1334 constituent reals. */
1340 if (size
* nrem
> BSWAP_BUFSZ
)
1341 nc
= BSWAP_BUFSZ
/ size
;
1345 #ifdef HAVE_GFC_REAL_17
1346 if ((dtp
->u
.p
.current_unit
->flags
.convert
& GFC_CONVERT_R16_IEEE
)
1348 && (type
== BT_REAL
|| type
== BT_COMPLEX
))
1350 for (size_t i
= 0; i
< nc
; i
++)
1354 memcpy (&r16
, p
, 16);
1356 memcpy (&buffer
[i
* 16], &r17
, 16);
1359 if ((dtp
->u
.p
.current_unit
->flags
.convert
1360 & ~(GFC_CONVERT_R16_IEEE
| GFC_CONVERT_R16_IBM
))
1361 == GFC_CONVERT_SWAP
)
1362 bswap_array (buffer
, buffer
, size
, nc
);
1364 else if ((dtp
->u
.p
.current_unit
->flags
.convert
& GFC_CONVERT_R16_IBM
)
1366 && (type
== BT_REAL
|| type
== BT_COMPLEX
))
1368 for (size_t i
= 0; i
< nc
; i
++)
1372 memcpy (&r17
, p
, 16);
1374 memcpy (&buffer
[i
* 16], &r16
, 16);
1377 if ((dtp
->u
.p
.current_unit
->flags
.convert
1378 & ~(GFC_CONVERT_R16_IEEE
| GFC_CONVERT_R16_IBM
))
1379 == GFC_CONVERT_SWAP
)
1380 bswap_array (buffer
, buffer
, size
/ 2, nc
* 2);
1382 else if (kind
== 16 && (type
== BT_REAL
|| type
== BT_COMPLEX
))
1384 bswap_array (buffer
, p
, size
/ 2, nc
* 2);
1390 bswap_array (buffer
, p
, size
, nc
);
1393 write_buf (dtp
, buffer
, size
* nc
);
1401 /* Return a pointer to the name of a type. */
1426 p
= "CLASS or DERIVED";
1429 internal_error (NULL
, "type_name(): Bad type");
1436 /* Write a constant string to the output.
1437 This is complicated because the string can have doubled delimiters
1438 in it. The length in the format node is the true length. */
1441 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
1443 char c
, delimiter
, *p
, *q
;
1446 length
= f
->u
.string
.length
;
1450 p
= write_block (dtp
, length
);
1457 for (; length
> 0; length
--)
1460 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
1461 q
++; /* Skip the doubled delimiter. */
1466 /* Given actual and expected types in a formatted data transfer, make
1467 sure they agree. If not, an error message is generated. Returns
1468 nonzero if something went wrong. */
1471 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
1474 char buffer
[BUFLEN
];
1476 if (actual
== expected
)
1479 /* Adjust item_count before emitting error message. */
1480 snprintf (buffer
, BUFLEN
,
1481 "Expected %s for item %d in formatted transfer, got %s",
1482 type_name (expected
), dtp
->u
.p
.item_count
- 1, type_name (actual
));
1484 format_error (dtp
, f
, buffer
);
1489 /* Check that the dtio procedure required for formatted IO is present. */
1492 check_dtio_proc (st_parameter_dt
*dtp
, const fnode
*f
)
1494 char buffer
[BUFLEN
];
1496 if (dtp
->u
.p
.fdtio_ptr
!= NULL
)
1499 snprintf (buffer
, BUFLEN
,
1500 "Missing DTIO procedure or intrinsic type passed for item %d "
1501 "in formatted transfer",
1502 dtp
->u
.p
.item_count
- 1);
1504 format_error (dtp
, f
, buffer
);
1510 require_numeric_type (st_parameter_dt
*dtp
, bt actual
, const fnode
*f
)
1513 char buffer
[BUFLEN
];
1515 if (actual
== BT_INTEGER
|| actual
== BT_REAL
|| actual
== BT_COMPLEX
)
1518 /* Adjust item_count before emitting error message. */
1519 snprintf (buffer
, BUFLEN
,
1520 "Expected numeric type for item %d in formatted transfer, got %s",
1521 dtp
->u
.p
.item_count
- 1, type_name (actual
));
1523 format_error (dtp
, f
, buffer
);
1528 get_dt_format (char *p
, gfc_charlen_type
*length
)
1530 char delim
= p
[-1]; /* The delimiter is always the first character back. */
1532 gfc_charlen_type len
= *length
; /* This length already correct, less 'DT'. */
1534 res
= q
= xmalloc (len
+ 2);
1536 /* Set the beginning of the string to 'DT', length adjusted below. */
1540 /* The string may contain doubled quotes so scan and skip as needed. */
1541 for (; len
> 0; len
--)
1545 p
++; /* Skip the doubled delimiter. */
1548 /* Adjust the string length by two now that we are done. */
1555 /* This function is in the main loop for a formatted data transfer
1556 statement. It would be natural to implement this as a coroutine
1557 with the user program, but C makes that awkward. We loop,
1558 processing format elements. When we actually have to transfer
1559 data instead of just setting flags, we return control to the user
1560 program which calls a function that supplies the address and type
1561 of the next element, then comes back here to process it. */
1564 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1567 int pos
, bytes_used
;
1571 int consume_data_flag
;
1573 /* Change a complex data item into a pair of reals. */
1575 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1576 if (type
== BT_COMPLEX
)
1582 /* If there's an EOR condition, we simulate finalizing the transfer
1583 by doing nothing. */
1584 if (dtp
->u
.p
.eor_condition
)
1587 /* Set this flag so that commas in reads cause the read to complete before
1588 the entire field has been read. The next read field will start right after
1589 the comma in the stream. (Set to 0 for character reads). */
1590 dtp
->u
.p
.sf_read_comma
=
1591 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1595 /* If reversion has occurred and there is another real data item,
1596 then we have to move to the next record. */
1597 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1599 dtp
->u
.p
.reversion_flag
= 0;
1600 next_record (dtp
, 0);
1603 consume_data_flag
= 1;
1604 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1607 f
= next_format (dtp
);
1610 /* No data descriptors left. */
1611 if (unlikely (n
> 0))
1612 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1613 "Insufficient data descriptors in format after reversion");
1619 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1620 - dtp
->u
.p
.current_unit
->bytes_left
);
1622 if (is_stream_io(dtp
))
1629 goto need_read_data
;
1630 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1632 read_decimal (dtp
, f
, p
, kind
);
1637 goto need_read_data
;
1638 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1639 && require_numeric_type (dtp
, type
, f
))
1641 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1642 && require_type (dtp
, BT_INTEGER
, type
, f
))
1644 #ifdef HAVE_GFC_REAL_17
1645 if (type
== BT_REAL
&& kind
== 17)
1648 read_radix (dtp
, f
, p
, kind
, 2);
1653 goto need_read_data
;
1654 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1655 && require_numeric_type (dtp
, type
, f
))
1657 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1658 && require_type (dtp
, BT_INTEGER
, type
, f
))
1660 #ifdef HAVE_GFC_REAL_17
1661 if (type
== BT_REAL
&& kind
== 17)
1664 read_radix (dtp
, f
, p
, kind
, 8);
1669 goto need_read_data
;
1670 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1671 && require_numeric_type (dtp
, type
, f
))
1673 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1674 && require_type (dtp
, BT_INTEGER
, type
, f
))
1676 #ifdef HAVE_GFC_REAL_17
1677 if (type
== BT_REAL
&& kind
== 17)
1680 read_radix (dtp
, f
, p
, kind
, 16);
1685 goto need_read_data
;
1687 /* It is possible to have FMT_A with something not BT_CHARACTER such
1688 as when writing out hollerith strings, so check both type
1689 and kind before calling wide character routines. */
1690 if (type
== BT_CHARACTER
&& kind
== 4)
1691 read_a_char4 (dtp
, f
, p
, size
);
1693 read_a (dtp
, f
, p
, size
);
1698 goto need_read_data
;
1699 read_l (dtp
, f
, p
, kind
);
1704 goto need_read_data
;
1705 if (require_type (dtp
, BT_REAL
, type
, f
))
1707 read_f (dtp
, f
, p
, kind
);
1712 goto need_read_data
;
1714 if (check_dtio_proc (dtp
, f
))
1716 if (require_type (dtp
, BT_CLASS
, type
, f
))
1718 GFC_INTEGER_4 unit
= dtp
->u
.p
.current_unit
->unit_number
;
1720 char tmp_iomsg
[IOMSG_LEN
] = "";
1722 gfc_charlen_type child_iomsg_len
;
1723 GFC_INTEGER_4 noiostat
;
1724 GFC_INTEGER_4
*child_iostat
= NULL
;
1726 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1728 /* Build the iotype string. */
1729 if (iotype_len
== 0)
1735 iotype
= get_dt_format (f
->u
.udf
.string
, &iotype_len
);
1737 /* Set iostat, intent(out). */
1739 child_iostat
= ((dtp
->common
.flags
& IOPARM_HAS_IOSTAT
)
1740 ? dtp
->common
.iostat
: &noiostat
);
1742 /* Set iomsg, intent(inout). */
1743 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1745 child_iomsg
= dtp
->common
.iomsg
;
1746 child_iomsg_len
= dtp
->common
.iomsg_len
;
1750 child_iomsg
= tmp_iomsg
;
1751 child_iomsg_len
= IOMSG_LEN
;
1754 /* Call the user defined formatted READ procedure. */
1755 dtp
->u
.p
.current_unit
->child_dtio
++;
1756 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
1757 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1758 child_iostat
, child_iomsg
,
1759 iotype_len
, child_iomsg_len
);
1760 dtp
->u
.p
.child_saved_iostat
= *child_iostat
;
1761 dtp
->u
.p
.current_unit
->child_dtio
--;
1763 if ((dtp
->u
.p
.child_saved_iostat
!= 0) &&
1764 !(dtp
->common
.flags
& IOPARM_HAS_IOMSG
) &&
1765 !(dtp
->common
.flags
& IOPARM_HAS_IOSTAT
))
1767 char message
[IOMSG_LEN
+ 1];
1768 child_iomsg_len
= string_len_trim (IOMSG_LEN
, child_iomsg
);
1769 fstrcpy (message
, child_iomsg_len
, child_iomsg
, child_iomsg_len
);
1770 message
[child_iomsg_len
] = '\0';
1771 generate_error (&dtp
->common
, dtp
->u
.p
.child_saved_iostat
,
1775 if (f
->u
.udf
.string_len
!= 0)
1777 /* Note: vlist is freed in free_format_data. */
1782 goto need_read_data
;
1783 if (require_type (dtp
, BT_REAL
, type
, f
))
1785 read_f (dtp
, f
, p
, kind
);
1790 goto need_read_data
;
1791 if (require_type (dtp
, BT_REAL
, type
, f
))
1793 read_f (dtp
, f
, p
, kind
);
1798 goto need_read_data
;
1799 if (require_type (dtp
, BT_REAL
, type
, f
))
1801 read_f (dtp
, f
, p
, kind
);
1806 goto need_read_data
;
1807 if (require_type (dtp
, BT_REAL
, type
, f
))
1809 read_f (dtp
, f
, p
, kind
);
1814 goto need_read_data
;
1818 read_decimal (dtp
, f
, p
, kind
);
1821 read_l (dtp
, f
, p
, kind
);
1825 read_a_char4 (dtp
, f
, p
, size
);
1827 read_a (dtp
, f
, p
, size
);
1830 read_f (dtp
, f
, p
, kind
);
1833 internal_error (&dtp
->common
,
1834 "formatted_transfer (): Bad type");
1839 consume_data_flag
= 0;
1840 format_error (dtp
, f
, "Constant string in input format");
1843 /* Format codes that don't transfer data. */
1846 consume_data_flag
= 0;
1847 dtp
->u
.p
.skips
+= f
->u
.n
;
1848 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1849 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1850 read_x (dtp
, f
->u
.n
);
1855 consume_data_flag
= 0;
1857 if (f
->format
== FMT_TL
)
1859 /* Handle the special case when no bytes have been used yet.
1860 Cannot go below zero. */
1861 if (bytes_used
== 0)
1863 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1864 dtp
->u
.p
.skips
-= f
->u
.n
;
1865 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1868 pos
= bytes_used
- f
->u
.n
;
1873 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1874 left tab limit. We do not check if the position has gone
1875 beyond the end of record because a subsequent tab could
1876 bring us back again. */
1877 pos
= pos
< 0 ? 0 : pos
;
1879 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1880 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1881 + pos
- dtp
->u
.p
.max_pos
;
1882 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1883 ? 0 : dtp
->u
.p
.pending_spaces
;
1884 if (dtp
->u
.p
.skips
== 0)
1887 /* Adjust everything for end-of-record condition */
1888 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1890 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1891 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1893 if (dtp
->u
.p
.pending_spaces
== 0)
1894 dtp
->u
.p
.sf_seen_eor
= 0;
1896 if (dtp
->u
.p
.skips
< 0)
1898 if (is_internal_unit (dtp
))
1899 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1901 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1902 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1903 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1906 read_x (dtp
, dtp
->u
.p
.skips
);
1910 consume_data_flag
= 0;
1911 dtp
->u
.p
.sign_status
= SIGN_PROCDEFINED
;
1915 consume_data_flag
= 0;
1916 dtp
->u
.p
.sign_status
= SIGN_SUPPRESS
;
1920 consume_data_flag
= 0;
1921 dtp
->u
.p
.sign_status
= SIGN_PLUS
;
1925 consume_data_flag
= 0 ;
1926 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1930 consume_data_flag
= 0;
1931 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1935 consume_data_flag
= 0;
1936 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1940 consume_data_flag
= 0;
1941 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1945 consume_data_flag
= 0;
1946 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1950 consume_data_flag
= 0;
1951 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1955 consume_data_flag
= 0;
1956 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1960 consume_data_flag
= 0;
1961 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1965 consume_data_flag
= 0;
1966 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1970 consume_data_flag
= 0;
1971 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1975 consume_data_flag
= 0;
1976 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1980 consume_data_flag
= 0;
1981 dtp
->u
.p
.seen_dollar
= 1;
1985 consume_data_flag
= 0;
1986 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1987 next_record (dtp
, 0);
1991 /* A colon descriptor causes us to exit this loop (in
1992 particular preventing another / descriptor from being
1993 processed) unless there is another data item to be
1995 consume_data_flag
= 0;
2001 internal_error (&dtp
->common
, "Bad format node");
2004 /* Adjust the item count and data pointer. */
2006 if ((consume_data_flag
> 0) && (n
> 0))
2009 p
= ((char *) p
) + size
;
2014 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
2015 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
2020 /* Come here when we need a data descriptor but don't have one. We
2021 push the current format node back onto the input, then return and
2022 let the user program call us back with the data. */
2024 unget_format (dtp
, f
);
2029 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2032 gfc_offset pos
, bytes_used
;
2036 int consume_data_flag
;
2038 /* Change a complex data item into a pair of reals. */
2040 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
2041 if (type
== BT_COMPLEX
)
2047 /* If there's an EOR condition, we simulate finalizing the transfer
2048 by doing nothing. */
2049 if (dtp
->u
.p
.eor_condition
)
2052 /* Set this flag so that commas in reads cause the read to complete before
2053 the entire field has been read. The next read field will start right after
2054 the comma in the stream. (Set to 0 for character reads). */
2055 dtp
->u
.p
.sf_read_comma
=
2056 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
2060 /* If reversion has occurred and there is another real data item,
2061 then we have to move to the next record. */
2062 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
2064 dtp
->u
.p
.reversion_flag
= 0;
2065 next_record (dtp
, 0);
2068 consume_data_flag
= 1;
2069 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2072 f
= next_format (dtp
);
2075 /* No data descriptors left. */
2076 if (unlikely (n
> 0))
2077 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
2078 "Insufficient data descriptors in format after reversion");
2082 /* Now discharge T, TR and X movements to the right. This is delayed
2083 until a data producing format to suppress trailing spaces. */
2086 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
2087 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
2088 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
2089 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
2090 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
2092 || t
== FMT_STRING
))
2094 if (dtp
->u
.p
.skips
> 0)
2097 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
2098 tmp
= dtp
->u
.p
.current_unit
->recl
2099 - dtp
->u
.p
.current_unit
->bytes_left
;
2101 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
2104 if (dtp
->u
.p
.skips
< 0)
2106 if (is_internal_unit (dtp
))
2107 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
2109 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
2110 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
2112 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2115 if (is_stream_io(dtp
))
2116 bytes_used
= dtp
->u
.p
.current_unit
->fbuf
->act
;
2118 bytes_used
= dtp
->u
.p
.current_unit
->recl
2119 - dtp
->u
.p
.current_unit
->bytes_left
;
2126 if (require_type (dtp
, BT_INTEGER
, type
, f
))
2128 write_i (dtp
, f
, p
, kind
);
2134 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
2135 && require_numeric_type (dtp
, type
, f
))
2137 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
2138 && require_type (dtp
, BT_INTEGER
, type
, f
))
2140 #ifdef HAVE_GFC_REAL_17
2141 if (type
== BT_REAL
&& kind
== 17)
2144 write_b (dtp
, f
, p
, kind
);
2150 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
2151 && require_numeric_type (dtp
, type
, f
))
2153 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
2154 && require_type (dtp
, BT_INTEGER
, type
, f
))
2156 #ifdef HAVE_GFC_REAL_17
2157 if (type
== BT_REAL
&& kind
== 17)
2160 write_o (dtp
, f
, p
, kind
);
2166 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
2167 && require_numeric_type (dtp
, type
, f
))
2169 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
2170 && require_type (dtp
, BT_INTEGER
, type
, f
))
2172 #ifdef HAVE_GFC_REAL_17
2173 if (type
== BT_REAL
&& kind
== 17)
2176 write_z (dtp
, f
, p
, kind
);
2183 /* It is possible to have FMT_A with something not BT_CHARACTER such
2184 as when writing out hollerith strings, so check both type
2185 and kind before calling wide character routines. */
2186 if (type
== BT_CHARACTER
&& kind
== 4)
2187 write_a_char4 (dtp
, f
, p
, size
);
2189 write_a (dtp
, f
, p
, size
);
2195 write_l (dtp
, f
, p
, kind
);
2201 if (require_type (dtp
, BT_REAL
, type
, f
))
2203 if (f
->u
.real
.w
== 0)
2204 write_real_w0 (dtp
, p
, kind
, f
);
2206 write_d (dtp
, f
, p
, kind
);
2212 GFC_INTEGER_4 unit
= dtp
->u
.p
.current_unit
->unit_number
;
2214 char tmp_iomsg
[IOMSG_LEN
] = "";
2216 gfc_charlen_type child_iomsg_len
;
2217 GFC_INTEGER_4 noiostat
;
2218 GFC_INTEGER_4
*child_iostat
= NULL
;
2220 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
2222 /* Build the iotype string. */
2223 if (iotype_len
== 0)
2229 iotype
= get_dt_format (f
->u
.udf
.string
, &iotype_len
);
2231 /* Set iostat, intent(out). */
2233 child_iostat
= ((dtp
->common
.flags
& IOPARM_HAS_IOSTAT
)
2234 ? dtp
->common
.iostat
: &noiostat
);
2236 /* Set iomsg, intent(inout). */
2237 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
2239 child_iomsg
= dtp
->common
.iomsg
;
2240 child_iomsg_len
= dtp
->common
.iomsg_len
;
2244 child_iomsg
= tmp_iomsg
;
2245 child_iomsg_len
= IOMSG_LEN
;
2248 if (check_dtio_proc (dtp
, f
))
2251 /* Call the user defined formatted WRITE procedure. */
2252 dtp
->u
.p
.current_unit
->child_dtio
++;
2254 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
2255 child_iostat
, child_iomsg
,
2256 iotype_len
, child_iomsg_len
);
2257 dtp
->u
.p
.child_saved_iostat
= *child_iostat
;
2258 dtp
->u
.p
.current_unit
->child_dtio
--;
2260 if ((dtp
->u
.p
.child_saved_iostat
!= 0) &&
2261 !(dtp
->common
.flags
& IOPARM_HAS_IOMSG
) &&
2262 !(dtp
->common
.flags
& IOPARM_HAS_IOSTAT
))
2264 char message
[IOMSG_LEN
+ 1];
2265 child_iomsg_len
= string_len_trim (IOMSG_LEN
, child_iomsg
);
2266 fstrcpy (message
, child_iomsg_len
, child_iomsg
, child_iomsg_len
);
2267 message
[child_iomsg_len
] = '\0';
2268 generate_error (&dtp
->common
, dtp
->u
.p
.child_saved_iostat
,
2272 if (f
->u
.udf
.string_len
!= 0)
2274 /* Note: vlist is freed in free_format_data. */
2280 if (require_type (dtp
, BT_REAL
, type
, f
))
2282 if (f
->u
.real
.w
== 0)
2283 write_real_w0 (dtp
, p
, kind
, f
);
2285 write_e (dtp
, f
, p
, kind
);
2291 if (require_type (dtp
, BT_REAL
, type
, f
))
2293 if (f
->u
.real
.w
== 0)
2294 write_real_w0 (dtp
, p
, kind
, f
);
2296 write_en (dtp
, f
, p
, kind
);
2302 if (require_type (dtp
, BT_REAL
, type
, f
))
2304 if (f
->u
.real
.w
== 0)
2305 write_real_w0 (dtp
, p
, kind
, f
);
2307 write_es (dtp
, f
, p
, kind
);
2313 if (require_type (dtp
, BT_REAL
, type
, f
))
2315 write_f (dtp
, f
, p
, kind
);
2324 write_i (dtp
, f
, p
, kind
);
2327 write_l (dtp
, f
, p
, kind
);
2331 write_a_char4 (dtp
, f
, p
, size
);
2333 write_a (dtp
, f
, p
, size
);
2336 if (f
->u
.real
.w
== 0)
2337 write_real_w0 (dtp
, p
, kind
, f
);
2339 write_d (dtp
, f
, p
, kind
);
2342 internal_error (&dtp
->common
,
2343 "formatted_transfer (): Bad type");
2348 consume_data_flag
= 0;
2349 write_constant_string (dtp
, f
);
2352 /* Format codes that don't transfer data. */
2355 consume_data_flag
= 0;
2357 dtp
->u
.p
.skips
+= f
->u
.n
;
2358 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
2359 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
2360 /* Writes occur just before the switch on f->format, above, so
2361 that trailing blanks are suppressed, unless we are doing a
2362 non-advancing write in which case we want to output the blanks
2364 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2366 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
2367 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2373 consume_data_flag
= 0;
2375 if (f
->format
== FMT_TL
)
2378 /* Handle the special case when no bytes have been used yet.
2379 Cannot go below zero. */
2380 if (bytes_used
== 0)
2382 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
2383 dtp
->u
.p
.skips
-= f
->u
.n
;
2384 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
2387 pos
= bytes_used
- f
->u
.n
;
2390 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
2392 /* Standard 10.6.1.1: excessive left tabbing is reset to the
2393 left tab limit. We do not check if the position has gone
2394 beyond the end of record because a subsequent tab could
2395 bring us back again. */
2396 pos
= pos
< 0 ? 0 : pos
;
2398 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
2399 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
2400 + pos
- dtp
->u
.p
.max_pos
;
2401 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
2402 ? 0 : dtp
->u
.p
.pending_spaces
;
2406 consume_data_flag
= 0;
2407 dtp
->u
.p
.sign_status
= SIGN_PROCDEFINED
;
2411 consume_data_flag
= 0;
2412 dtp
->u
.p
.sign_status
= SIGN_SUPPRESS
;
2416 consume_data_flag
= 0;
2417 dtp
->u
.p
.sign_status
= SIGN_PLUS
;
2421 consume_data_flag
= 0 ;
2422 dtp
->u
.p
.blank_status
= BLANK_NULL
;
2426 consume_data_flag
= 0;
2427 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
2431 consume_data_flag
= 0;
2432 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
2436 consume_data_flag
= 0;
2437 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
2441 consume_data_flag
= 0;
2442 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
2446 consume_data_flag
= 0;
2447 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
2451 consume_data_flag
= 0;
2452 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
2456 consume_data_flag
= 0;
2457 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
2461 consume_data_flag
= 0;
2462 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
2466 consume_data_flag
= 0;
2467 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
2471 consume_data_flag
= 0;
2472 dtp
->u
.p
.scale_factor
= f
->u
.k
;
2476 consume_data_flag
= 0;
2477 dtp
->u
.p
.seen_dollar
= 1;
2481 consume_data_flag
= 0;
2482 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2483 next_record (dtp
, 0);
2487 /* A colon descriptor causes us to exit this loop (in
2488 particular preventing another / descriptor from being
2489 processed) unless there is another data item to be
2491 consume_data_flag
= 0;
2497 internal_error (&dtp
->common
, "Bad format node");
2500 /* Adjust the item count and data pointer. */
2502 if ((consume_data_flag
> 0) && (n
> 0))
2505 p
= ((char *) p
) + size
;
2508 if (is_stream_io(dtp
))
2509 pos
= dtp
->u
.p
.current_unit
->fbuf
->act
;
2511 pos
= dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
;
2513 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
2518 /* Come here when we need a data descriptor but don't have one. We
2519 push the current format node back onto the input, then return and
2520 let the user program call us back with the data. */
2522 unget_format (dtp
, f
);
2525 /* This function is first called from data_init_transfer to initiate the loop
2526 over each item in the format, transferring data as required. Subsequent
2527 calls to this function occur for each data item foound in the READ/WRITE
2528 statement. The item_count is incremented for each call. Since the first
2529 call is from data_transfer_init, the item_count is always one greater than
2530 the actual count number of the item being transferred. */
2533 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2534 size_t size
, size_t nelems
)
2540 size_t stride
= type
== BT_CHARACTER
?
2541 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2542 if (dtp
->u
.p
.mode
== READING
)
2544 /* Big loop over all the elements. */
2545 for (elem
= 0; elem
< nelems
; elem
++)
2547 dtp
->u
.p
.item_count
++;
2548 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2553 /* Big loop over all the elements. */
2554 for (elem
= 0; elem
< nelems
; elem
++)
2556 dtp
->u
.p
.item_count
++;
2557 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2562 /* Wrapper function for I/O of scalar types. If this should be an async I/O
2563 request, queue it. For a synchronous write on an async unit, perform the
2564 wait operation and return an error. For all synchronous writes, call the
2565 right transfer function. */
2568 wrap_scalar_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2569 size_t size
, size_t n_elem
)
2571 if (dtp
->u
.p
.current_unit
&& dtp
->u
.p
.current_unit
->au
)
2576 args
.scalar
.transfer
= dtp
->u
.p
.transfer
;
2577 args
.scalar
.arg_bt
= type
;
2578 args
.scalar
.data
= p
;
2579 args
.scalar
.i
= kind
;
2580 args
.scalar
.s1
= size
;
2581 args
.scalar
.s2
= n_elem
;
2582 enqueue_transfer (dtp
->u
.p
.current_unit
->au
, &args
,
2583 AIO_TRANSFER_SCALAR
);
2587 /* Come here if there was no asynchronous I/O to be scheduled. */
2588 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2591 dtp
->u
.p
.transfer (dtp
, type
, p
, kind
, size
, 1);
2595 /* Data transfer entry points. The type of the data entity is
2596 implicit in the subroutine call. This prevents us from having to
2597 share a common enum with the compiler. */
2600 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
2602 wrap_scalar_transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
2606 transfer_integer_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2608 transfer_integer (dtp
, p
, kind
);
2612 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
2615 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2617 size
= size_from_real_kind (kind
);
2618 wrap_scalar_transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
2622 transfer_real_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2624 transfer_real (dtp
, p
, kind
);
2628 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
2630 wrap_scalar_transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
2634 transfer_logical_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2636 transfer_logical (dtp
, p
, kind
);
2640 transfer_character (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
)
2642 static char *empty_string
[0];
2644 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2647 /* Strings of zero length can have p == NULL, which confuses the
2648 transfer routines into thinking we need more data elements. To avoid
2649 this, we give them a nice pointer. */
2650 if (len
== 0 && p
== NULL
)
2653 /* Set kind here to 1. */
2654 wrap_scalar_transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
2658 transfer_character_write (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
)
2660 transfer_character (dtp
, p
, len
);
2664 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
, int kind
)
2666 static char *empty_string
[0];
2668 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2671 /* Strings of zero length can have p == NULL, which confuses the
2672 transfer routines into thinking we need more data elements. To avoid
2673 this, we give them a nice pointer. */
2674 if (len
== 0 && p
== NULL
)
2677 /* Here we pass the actual kind value. */
2678 wrap_scalar_transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
2682 transfer_character_wide_write (st_parameter_dt
*dtp
, void *p
, gfc_charlen_type len
, int kind
)
2684 transfer_character_wide (dtp
, p
, len
, kind
);
2688 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
2691 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2693 size
= size_from_complex_kind (kind
);
2694 wrap_scalar_transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
2698 transfer_complex_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2700 transfer_complex (dtp
, p
, kind
);
2704 transfer_array_inner (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2705 gfc_charlen_type charlen
)
2707 index_type count
[GFC_MAX_DIMENSIONS
];
2708 index_type extent
[GFC_MAX_DIMENSIONS
];
2709 index_type stride
[GFC_MAX_DIMENSIONS
];
2710 index_type stride0
, rank
, size
, n
;
2715 /* Adjust item_count before emitting error message. */
2717 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2720 iotype
= (bt
) GFC_DESCRIPTOR_TYPE (desc
);
2721 size
= iotype
== BT_CHARACTER
? charlen
: GFC_DESCRIPTOR_SIZE (desc
);
2723 rank
= GFC_DESCRIPTOR_RANK (desc
);
2725 for (n
= 0; n
< rank
; n
++)
2728 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
2729 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
2731 /* If the extent of even one dimension is zero, then the entire
2732 array section contains zero elements, so we return after writing
2733 a zero array record. */
2738 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2743 stride0
= stride
[0];
2745 /* If the innermost dimension has a stride of 1, we can do the transfer
2746 in contiguous chunks. */
2747 if (stride0
== size
)
2752 data
= GFC_DESCRIPTOR_DATA (desc
);
2754 /* When reading, we need to check endfile conditions so we do not miss
2755 an END=label. Make this separate so we do not have an extra test
2756 in a tight loop when it is not needed. */
2758 if (dtp
->u
.p
.current_unit
&& dtp
->u
.p
.mode
== READING
)
2762 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
))
2765 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2766 data
+= stride0
* tsize
;
2769 while (count
[n
] == extent
[n
])
2772 data
-= stride
[n
] * extent
[n
];
2791 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2792 data
+= stride0
* tsize
;
2795 while (count
[n
] == extent
[n
])
2798 data
-= stride
[n
] * extent
[n
];
2816 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2817 gfc_charlen_type charlen
)
2819 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2822 if (dtp
->u
.p
.current_unit
&& dtp
->u
.p
.current_unit
->au
)
2827 size_t sz
= sizeof (gfc_array_char
)
2828 + sizeof (descriptor_dimension
)
2829 * GFC_DESCRIPTOR_RANK (desc
);
2830 args
.array
.desc
= xmalloc (sz
);
2831 NOTE ("desc = %p", (void *) args
.array
.desc
);
2832 memcpy (args
.array
.desc
, desc
, sz
);
2833 args
.array
.kind
= kind
;
2834 args
.array
.charlen
= charlen
;
2835 enqueue_transfer (dtp
->u
.p
.current_unit
->au
, &args
,
2836 AIO_TRANSFER_ARRAY
);
2840 /* Come here if there was no asynchronous I/O to be scheduled. */
2841 transfer_array_inner (dtp
, desc
, kind
, charlen
);
2846 transfer_array_write (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2847 gfc_charlen_type charlen
)
2849 transfer_array (dtp
, desc
, kind
, charlen
);
2853 /* User defined input/output iomsg. */
2855 #define IOMSG_LEN 256
2858 transfer_derived (st_parameter_dt
*parent
, void *dtio_source
, void *dtio_proc
)
2860 if (parent
->u
.p
.current_unit
)
2862 if (parent
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2863 parent
->u
.p
.ufdtio_ptr
= (unformatted_dtio
) dtio_proc
;
2865 parent
->u
.p
.fdtio_ptr
= (formatted_dtio
) dtio_proc
;
2867 wrap_scalar_transfer (parent
, BT_CLASS
, dtio_source
, 0, 0, 1);
2871 /* Preposition a sequential unformatted file while reading. */
2874 us_read (st_parameter_dt
*dtp
, int continued
)
2881 if (compile_options
.record_marker
== 0)
2882 n
= sizeof (GFC_INTEGER_4
);
2884 n
= compile_options
.record_marker
;
2886 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
2887 if (unlikely (nr
< 0))
2889 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2895 return; /* end of file */
2897 else if (unlikely (n
!= nr
))
2899 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2903 int convert
= dtp
->u
.p
.current_unit
->flags
.convert
;
2904 #ifdef HAVE_GFC_REAL_17
2905 convert
&= ~(GFC_CONVERT_R16_IEEE
| GFC_CONVERT_R16_IBM
);
2907 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2908 if (likely (convert
== GFC_CONVERT_NATIVE
))
2912 case sizeof(GFC_INTEGER_4
):
2913 memcpy (&i4
, &i
, sizeof (i4
));
2917 case sizeof(GFC_INTEGER_8
):
2918 memcpy (&i8
, &i
, sizeof (i8
));
2923 runtime_error ("Illegal value for record marker");
2933 case sizeof(GFC_INTEGER_4
):
2934 memcpy (&u32
, &i
, sizeof (u32
));
2935 u32
= __builtin_bswap32 (u32
);
2936 memcpy (&i4
, &u32
, sizeof (i4
));
2940 case sizeof(GFC_INTEGER_8
):
2941 memcpy (&u64
, &i
, sizeof (u64
));
2942 u64
= __builtin_bswap64 (u64
);
2943 memcpy (&i8
, &u64
, sizeof (i8
));
2948 runtime_error ("Illegal value for record marker");
2955 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
2956 dtp
->u
.p
.current_unit
->continued
= 0;
2960 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
2961 dtp
->u
.p
.current_unit
->continued
= 1;
2965 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2969 /* Preposition a sequential unformatted file while writing. This
2970 amount to writing a bogus length that will be filled in later. */
2973 us_write (st_parameter_dt
*dtp
, int continued
)
2980 if (compile_options
.record_marker
== 0)
2981 nbytes
= sizeof (GFC_INTEGER_4
);
2983 nbytes
= compile_options
.record_marker
;
2985 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2986 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2988 /* For sequential unformatted, if RECL= was not specified in the OPEN
2989 we write until we have more bytes than can fit in the subrecord
2990 markers, then we write a new subrecord. */
2992 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2993 dtp
->u
.p
.current_unit
->recl_subrecord
;
2994 dtp
->u
.p
.current_unit
->continued
= continued
;
2998 /* Position to the next record prior to transfer. We are assumed to
2999 be before the next record. We also calculate the bytes in the next
3003 pre_position (st_parameter_dt
*dtp
)
3005 if (dtp
->u
.p
.current_unit
->current_record
)
3006 return; /* Already positioned. */
3008 switch (current_mode (dtp
))
3010 case FORMATTED_STREAM
:
3011 case UNFORMATTED_STREAM
:
3012 /* There are no records with stream I/O. If the position was specified
3013 data_transfer_init has already positioned the file. If no position
3014 was specified, we continue from where we last left off. I.e.
3015 there is nothing to do here. */
3018 case UNFORMATTED_SEQUENTIAL
:
3019 if (dtp
->u
.p
.mode
== READING
)
3026 case FORMATTED_SEQUENTIAL
:
3027 case FORMATTED_DIRECT
:
3028 case UNFORMATTED_DIRECT
:
3029 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3031 case FORMATTED_UNSPECIFIED
:
3035 dtp
->u
.p
.current_unit
->current_record
= 1;
3039 /* Initialize things for a data transfer. This code is common for
3040 both reading and writing. */
3043 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
3045 unit_flags u_flags
; /* Used for creating a unit if needed. */
3046 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3047 namelist_info
*ionml
;
3050 NOTE ("data_transfer_init");
3052 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
3054 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3056 dtp
->u
.p
.ionml
= ionml
;
3057 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
3058 dtp
->u
.p
.namelist_mode
= 0;
3059 dtp
->u
.p
.cc
.len
= 0;
3061 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3064 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
3066 if (dtp
->u
.p
.current_unit
== NULL
)
3068 /* This means we tried to access an external unit < 0 without
3069 having opened it first with NEWUNIT=. */
3070 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3071 "Unit number is negative and unit was not already "
3072 "opened with OPEN(NEWUNIT=...)");
3075 else if (dtp
->u
.p
.current_unit
->s
== NULL
)
3076 { /* Open the unit with some default flags. */
3077 st_parameter_open opp
;
3079 NOTE ("Open the unit with some default flags.");
3080 memset (&u_flags
, '\0', sizeof (u_flags
));
3081 u_flags
.access
= ACCESS_SEQUENTIAL
;
3082 u_flags
.action
= ACTION_READWRITE
;
3084 /* Is it unformatted? */
3085 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
3086 | IOPARM_DT_IONML_SET
)))
3087 u_flags
.form
= FORM_UNFORMATTED
;
3089 u_flags
.form
= FORM_UNSPECIFIED
;
3091 u_flags
.delim
= DELIM_UNSPECIFIED
;
3092 u_flags
.blank
= BLANK_UNSPECIFIED
;
3093 u_flags
.pad
= PAD_UNSPECIFIED
;
3094 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
3095 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
3096 u_flags
.async
= ASYNC_UNSPECIFIED
;
3097 u_flags
.round
= ROUND_UNSPECIFIED
;
3098 u_flags
.sign
= SIGN_UNSPECIFIED
;
3099 u_flags
.share
= SHARE_UNSPECIFIED
;
3100 u_flags
.cc
= CC_UNSPECIFIED
;
3101 u_flags
.readonly
= 0;
3103 u_flags
.status
= STATUS_UNKNOWN
;
3105 conv
= get_unformatted_convert (dtp
->common
.unit
);
3107 if (conv
== GFC_CONVERT_NONE
)
3108 conv
= compile_options
.convert
;
3110 u_flags
.convert
= 0;
3112 #ifdef HAVE_GFC_REAL_17
3113 u_flags
.convert
= conv
& (GFC_CONVERT_R16_IEEE
| GFC_CONVERT_R16_IBM
);
3114 conv
&= ~(GFC_CONVERT_R16_IEEE
| GFC_CONVERT_R16_IBM
);
3119 case GFC_CONVERT_NATIVE
:
3120 case GFC_CONVERT_SWAP
:
3123 case GFC_CONVERT_BIG
:
3124 conv
= __BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
3127 case GFC_CONVERT_LITTLE
:
3128 conv
= __BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
3132 internal_error (&opp
.common
, "Illegal value for CONVERT");
3136 u_flags
.convert
|= conv
;
3138 opp
.common
= dtp
->common
;
3139 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
3140 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
3141 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
3142 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
3143 if (dtp
->u
.p
.current_unit
== NULL
)
3147 if (dtp
->u
.p
.current_unit
->child_dtio
== 0)
3149 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
3151 dtp
->u
.p
.current_unit
->has_size
= true;
3152 /* Initialize the count. */
3153 dtp
->u
.p
.current_unit
->size_used
= 0;
3156 dtp
->u
.p
.current_unit
->has_size
= false;
3158 else if (dtp
->u
.p
.current_unit
->internal_unit_kind
> 0)
3159 dtp
->u
.p
.unit_is_internal
= 1;
3161 if ((cf
& IOPARM_DT_HAS_ASYNCHRONOUS
) != 0)
3164 f
= find_option (&dtp
->common
, dtp
->asynchronous
, dtp
->asynchronous_len
,
3165 async_opt
, "Bad ASYNCHRONOUS in data transfer "
3167 if (f
== ASYNC_YES
&& dtp
->u
.p
.current_unit
->flags
.async
!= ASYNC_YES
)
3169 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3170 "ASYNCHRONOUS transfer without "
3171 "ASYHCRONOUS='YES' in OPEN");
3174 dtp
->u
.p
.async
= f
== ASYNC_YES
;
3177 au
= dtp
->u
.p
.current_unit
->au
;
3182 /* If this is an asynchronous I/O statement, collect errors and
3183 return if there are any. */
3184 if (collect_async_errors (&dtp
->common
, au
))
3189 /* Synchronous statement: Perform a wait operation for any pending
3190 asynchronous I/O. This needs to be done before all other error
3191 checks. See F2008, 9.6.4.1. */
3192 if (async_wait (&(dtp
->common
), au
))
3197 /* Check the action. */
3199 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
3201 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
3202 "Cannot read from file opened for WRITE");
3206 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
3208 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
3209 "Cannot write to file opened for READ");
3213 dtp
->u
.p
.first_item
= 1;
3215 /* Check the format. */
3217 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
3220 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
3221 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
3224 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3225 "Format present for UNFORMATTED data transfer");
3229 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
3231 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
3233 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3234 "A format cannot be specified with a namelist");
3238 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
3239 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
3241 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3242 "Missing format for FORMATTED data transfer");
3246 if (is_internal_unit (dtp
)
3247 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3249 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3250 "Internal file cannot be accessed by UNFORMATTED "
3255 /* Check the record or position number. */
3257 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
3258 && (cf
& IOPARM_DT_HAS_REC
) == 0)
3260 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
3261 "Direct access data transfer requires record number");
3265 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3267 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
3269 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3270 "Record number not allowed for sequential access "
3275 if (compile_options
.warn_std
&&
3276 dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
)
3278 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3279 "Sequential READ or WRITE not allowed after "
3280 "EOF marker, possibly use REWIND or BACKSPACE");
3285 /* Process the ADVANCE option. */
3287 dtp
->u
.p
.advance_status
3288 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
3289 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
3290 "Bad ADVANCE parameter in data transfer statement");
3292 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
3294 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3296 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3297 "ADVANCE specification conflicts with sequential "
3302 if (is_internal_unit (dtp
))
3304 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3305 "ADVANCE specification conflicts with internal file");
3309 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
3310 != IOPARM_DT_HAS_FORMAT
)
3312 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3313 "ADVANCE specification requires an explicit format");
3318 /* Child IO is non-advancing and any ADVANCE= specifier is ignored.
3320 if (dtp
->u
.p
.current_unit
->child_dtio
> 0)
3321 dtp
->u
.p
.advance_status
= ADVANCE_NO
;
3325 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
3327 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3329 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
3330 "EOR specification requires an ADVANCE specification "
3335 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
3336 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3338 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
3339 "SIZE specification requires an ADVANCE "
3340 "specification of NO");
3345 { /* Write constraints. */
3346 if ((cf
& IOPARM_END
) != 0)
3348 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3349 "END specification cannot appear in a write "
3354 if ((cf
& IOPARM_EOR
) != 0)
3356 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3357 "EOR specification cannot appear in a write "
3362 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
3364 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3365 "SIZE specification cannot appear in a write "
3371 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
3372 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
3374 /* Check the decimal mode. */
3375 dtp
->u
.p
.current_unit
->decimal_status
3376 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
3377 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
3378 decimal_opt
, "Bad DECIMAL parameter in data transfer "
3381 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
3382 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
3384 /* Check the round mode. */
3385 dtp
->u
.p
.current_unit
->round_status
3386 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
3387 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
3388 round_opt
, "Bad ROUND parameter in data transfer "
3391 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
3392 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
3394 /* Check the sign mode. */
3395 dtp
->u
.p
.sign_status
3396 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
3397 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
3398 "Bad SIGN parameter in data transfer statement");
3400 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
3401 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
3403 /* Check the blank mode. */
3404 dtp
->u
.p
.blank_status
3405 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
3406 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
3408 "Bad BLANK parameter in data transfer statement");
3410 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
3411 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
3413 /* Check the delim mode. */
3414 dtp
->u
.p
.current_unit
->delim_status
3415 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
3416 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
3417 delim_opt
, "Bad DELIM parameter in data transfer statement");
3419 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
3421 if (ionml
&& dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_UNSPECIFIED
)
3422 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
3424 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
3427 /* Check the pad mode. */
3428 dtp
->u
.p
.current_unit
->pad_status
3429 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
3430 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
3431 "Bad PAD parameter in data transfer statement");
3433 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
3434 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
3436 /* Set up the subroutine that will handle the transfers. */
3440 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3441 dtp
->u
.p
.transfer
= unformatted_read
;
3444 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3445 dtp
->u
.p
.transfer
= list_formatted_read
;
3447 dtp
->u
.p
.transfer
= formatted_transfer
;
3452 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3453 dtp
->u
.p
.transfer
= unformatted_write
;
3456 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3457 dtp
->u
.p
.transfer
= list_formatted_write
;
3459 dtp
->u
.p
.transfer
= formatted_transfer
;
3463 if (au
&& dtp
->u
.p
.async
)
3465 NOTE ("enqueue_data_transfer");
3466 enqueue_data_transfer_init (au
, dtp
, read_flag
);
3470 NOTE ("invoking data_transfer_init_worker");
3471 data_transfer_init_worker (dtp
, read_flag
);
3476 data_transfer_init_worker (st_parameter_dt
*dtp
, int read_flag
)
3478 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3480 NOTE ("starting worker...");
3482 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.form
!= FORM_UNFORMATTED
3483 && ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3484 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
3485 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
3487 /* Check to see if we might be reading what we wrote before */
3489 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
3490 && !is_internal_unit (dtp
))
3492 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
3494 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
3495 sflush(dtp
->u
.p
.current_unit
->s
);
3498 /* Check the POS= specifier: that it is in range and that it is used with a
3499 unit that has been connected for STREAM access. F2003 9.5.1.10. */
3501 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
3503 if (is_stream_io (dtp
))
3508 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3509 "POS=specifier must be positive");
3513 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
3515 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3516 "POS=specifier too large");
3520 dtp
->rec
= dtp
->pos
;
3522 if (dtp
->u
.p
.mode
== READING
)
3524 /* Reset the endfile flag; if we hit EOF during reading
3525 we'll set the flag and generate an error at that point
3526 rather than worrying about it here. */
3527 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
3530 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
3532 fbuf_reset (dtp
->u
.p
.current_unit
);
3533 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1,
3536 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3539 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
3544 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3545 "POS=specifier not allowed, "
3546 "Try OPEN with ACCESS='stream'");
3552 /* Sanity checks on the record number. */
3553 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
3557 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3558 "Record number must be positive");
3562 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
3564 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3565 "Record number too large");
3569 /* Make sure format buffer is reset. */
3570 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3571 fbuf_reset (dtp
->u
.p
.current_unit
);
3574 /* Check whether the record exists to be read. Only
3575 a partial record needs to exist. */
3577 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
3578 * dtp
->u
.p
.current_unit
->recl
>= ssize (dtp
->u
.p
.current_unit
->s
))
3580 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3581 "Non-existing record number");
3585 /* Position the file. */
3586 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
3587 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
3589 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3593 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
3595 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3596 "Record number not allowed for stream access "
3602 /* Bugware for badly written mixed C-Fortran I/O. */
3603 if (!is_internal_unit (dtp
))
3604 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
3606 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
3608 /* Set the maximum position reached from the previous I/O operation. This
3609 could be greater than zero from a previous non-advancing write. */
3610 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
3614 /* Make sure that we don't do a read after a nonadvancing write. */
3618 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
3620 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3621 "Cannot READ after a nonadvancing WRITE");
3627 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
3628 dtp
->u
.p
.current_unit
->read_bad
= 1;
3631 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3633 #ifdef HAVE_POSIX_2008_LOCALE
3634 dtp
->u
.p
.old_locale
= uselocale (c_locale
);
3636 __gthread_mutex_lock (&old_locale_lock
);
3637 if (!old_locale_ctr
++)
3639 old_locale
= setlocale (LC_NUMERIC
, NULL
);
3640 setlocale (LC_NUMERIC
, "C");
3642 __gthread_mutex_unlock (&old_locale_lock
);
3644 /* Start the data transfer if we are doing a formatted transfer. */
3645 if ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0
3646 && dtp
->u
.p
.ionml
== NULL
)
3647 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
3652 /* Initialize an array_loop_spec given the array descriptor. The function
3653 returns the index of the last element of the array, and also returns
3654 starting record, where the first I/O goes to (necessary in case of
3655 negative strides). */
3658 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
3659 gfc_offset
*start_record
)
3661 int rank
= GFC_DESCRIPTOR_RANK(desc
);
3670 for (i
=0; i
<rank
; i
++)
3672 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3673 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3674 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
3675 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
3676 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
3677 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
3679 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
3681 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3682 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3686 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3687 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3688 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3689 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3699 /* Determine the index to the next record in an internal unit array by
3700 by incrementing through the array_loop_spec. */
3703 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
3711 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
3716 if (ls
[i
].idx
> ls
[i
].end
)
3718 ls
[i
].idx
= ls
[i
].start
;
3724 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
3734 /* Skip to the end of the current record, taking care of an optional
3735 record marker of size bytes. If the file is not seekable, we
3736 read chunks of size MAX_READ until we get to the right
3740 skip_record (st_parameter_dt
*dtp
, gfc_offset bytes
)
3742 ssize_t rlength
, readb
;
3743 #define MAX_READ 4096
3746 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
3747 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
3750 /* Direct access files do not generate END conditions,
3752 if (sseek (dtp
->u
.p
.current_unit
->s
,
3753 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
3755 /* Seeking failed, fall back to seeking by reading data. */
3756 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
3759 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
3760 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3762 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
3765 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3769 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
3773 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= 0;
3777 /* Advance to the next record reading unformatted files, taking
3778 care of subrecords. If complete_record is nonzero, we loop
3779 until all subrecords are cleared. */
3782 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
3786 bytes
= compile_options
.record_marker
== 0 ?
3787 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
3792 /* Skip over tail */
3794 skip_record (dtp
, bytes
);
3796 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
3805 min_off (gfc_offset a
, gfc_offset b
)
3807 return (a
< b
? a
: b
);
3811 /* Space to the next record for read mode. */
3814 next_record_r (st_parameter_dt
*dtp
, int done
)
3820 switch (current_mode (dtp
))
3822 /* No records in unformatted STREAM I/O. */
3823 case UNFORMATTED_STREAM
:
3826 case UNFORMATTED_SEQUENTIAL
:
3827 next_record_r_unf (dtp
, 1);
3828 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3831 case FORMATTED_DIRECT
:
3832 case UNFORMATTED_DIRECT
:
3833 skip_record (dtp
, dtp
->u
.p
.current_unit
->bytes_left
);
3836 case FORMATTED_STREAM
:
3837 case FORMATTED_SEQUENTIAL
:
3838 /* read_sf has already terminated input because of an '\n', or
3840 if (dtp
->u
.p
.sf_seen_eor
)
3842 dtp
->u
.p
.sf_seen_eor
= 0;
3846 if (is_internal_unit (dtp
))
3848 if (is_array_io (dtp
))
3852 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3854 if (!done
&& finished
)
3857 /* Now seek to this record. */
3858 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3859 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3861 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3864 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3868 gfc_offset bytes_left
= dtp
->u
.p
.current_unit
->bytes_left
;
3869 bytes_left
= min_off (bytes_left
,
3870 ssize (dtp
->u
.p
.current_unit
->s
)
3871 - stell (dtp
->u
.p
.current_unit
->s
));
3872 if (sseek (dtp
->u
.p
.current_unit
->s
,
3873 bytes_left
, SEEK_CUR
) < 0)
3875 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3878 dtp
->u
.p
.current_unit
->bytes_left
3879 = dtp
->u
.p
.current_unit
->recl
;
3883 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
3888 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
3892 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3895 if (is_stream_io (dtp
)
3896 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
3897 || dtp
->u
.p
.current_unit
->bytes_left
3898 == dtp
->u
.p
.current_unit
->recl
)
3904 if (is_stream_io (dtp
))
3905 dtp
->u
.p
.current_unit
->strm_pos
++;
3912 case FORMATTED_UNSPECIFIED
:
3918 /* Small utility function to write a record marker, taking care of
3919 byte swapping and of choosing the correct size. */
3922 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
3928 if (compile_options
.record_marker
== 0)
3929 len
= sizeof (GFC_INTEGER_4
);
3931 len
= compile_options
.record_marker
;
3933 int convert
= dtp
->u
.p
.current_unit
->flags
.convert
;
3934 #ifdef HAVE_GFC_REAL_17
3935 convert
&= ~(GFC_CONVERT_R16_IEEE
| GFC_CONVERT_R16_IBM
);
3937 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
3938 if (likely (convert
== GFC_CONVERT_NATIVE
))
3942 case sizeof (GFC_INTEGER_4
):
3944 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
3947 case sizeof (GFC_INTEGER_8
):
3949 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
3953 runtime_error ("Illegal value for record marker");
3963 case sizeof (GFC_INTEGER_4
):
3965 memcpy (&u32
, &buf4
, sizeof (u32
));
3966 u32
= __builtin_bswap32 (u32
);
3967 return swrite (dtp
->u
.p
.current_unit
->s
, &u32
, len
);
3970 case sizeof (GFC_INTEGER_8
):
3972 memcpy (&u64
, &buf8
, sizeof (u64
));
3973 u64
= __builtin_bswap64 (u64
);
3974 return swrite (dtp
->u
.p
.current_unit
->s
, &u64
, len
);
3978 runtime_error ("Illegal value for record marker");
3985 /* Position to the next (sub)record in write mode for
3986 unformatted sequential files. */
3989 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
3991 gfc_offset m
, m_write
, record_marker
;
3993 /* Bytes written. */
3994 m
= dtp
->u
.p
.current_unit
->recl_subrecord
3995 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3997 if (compile_options
.record_marker
== 0)
3998 record_marker
= sizeof (GFC_INTEGER_4
);
4000 record_marker
= compile_options
.record_marker
;
4002 /* Seek to the head and overwrite the bogus length with the real
4005 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- record_marker
,
4014 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
4017 /* Seek past the end of the current record. */
4019 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
, SEEK_CUR
) < 0))
4022 /* Write the length tail. If we finish a record containing
4023 subrecords, we write out the negative length. */
4025 if (dtp
->u
.p
.current_unit
->continued
)
4030 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
4036 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
4042 /* Utility function like memset() but operating on streams. Return
4043 value is same as for POSIX write(). */
4046 sset (stream
*s
, int c
, gfc_offset nbyte
)
4048 #define WRITE_CHUNK 256
4049 char p
[WRITE_CHUNK
];
4050 gfc_offset bytes_left
;
4053 if (nbyte
< WRITE_CHUNK
)
4054 memset (p
, c
, nbyte
);
4056 memset (p
, c
, WRITE_CHUNK
);
4059 while (bytes_left
> 0)
4061 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
4062 trans
= swrite (s
, p
, trans
);
4065 bytes_left
-= trans
;
4068 return nbyte
- bytes_left
;
4072 /* Finish up a record according to the legacy carriagecontrol type, based
4073 on the first character in the record. */
4076 next_record_cc (st_parameter_dt
*dtp
)
4078 /* Only valid with CARRIAGECONTROL=FORTRAN. */
4079 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
4082 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
4083 if (dtp
->u
.p
.cc
.len
> 0)
4085 char *p
= fbuf_alloc (dtp
->u
.p
.current_unit
, dtp
->u
.p
.cc
.len
);
4087 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
4089 /* Output CR for the first character with default CC setting. */
4090 *(p
++) = dtp
->u
.p
.cc
.u
.end
;
4091 if (dtp
->u
.p
.cc
.len
> 1)
4092 *p
= dtp
->u
.p
.cc
.u
.end
;
4096 /* Position to the next record in write mode. */
4099 next_record_w (st_parameter_dt
*dtp
, int done
)
4101 gfc_offset max_pos_off
;
4103 /* Zero counters for X- and T-editing. */
4104 max_pos_off
= dtp
->u
.p
.max_pos
;
4105 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
4107 switch (current_mode (dtp
))
4109 /* No records in unformatted STREAM I/O. */
4110 case UNFORMATTED_STREAM
:
4113 case FORMATTED_DIRECT
:
4114 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
4117 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
4118 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
4119 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
4120 dtp
->u
.p
.current_unit
->bytes_left
)
4121 != dtp
->u
.p
.current_unit
->bytes_left
)
4126 case UNFORMATTED_DIRECT
:
4127 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
4129 gfc_offset length
= dtp
->u
.p
.current_unit
->bytes_left
;
4130 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
4135 case UNFORMATTED_SEQUENTIAL
:
4136 next_record_w_unf (dtp
, 0);
4137 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
4140 case FORMATTED_STREAM
:
4141 case FORMATTED_SEQUENTIAL
:
4143 if (is_internal_unit (dtp
))
4146 /* Internal unit, so must fit in memory. */
4148 size_t max_pos
= max_pos_off
;
4149 if (is_array_io (dtp
))
4153 length
= dtp
->u
.p
.current_unit
->bytes_left
;
4155 /* If the farthest position reached is greater than current
4156 position, adjust the position and set length to pad out
4157 whats left. Otherwise just pad whats left.
4158 (for character array unit) */
4159 m
= dtp
->u
.p
.current_unit
->recl
4160 - dtp
->u
.p
.current_unit
->bytes_left
;
4163 length
= (max_pos
- m
);
4164 if (sseek (dtp
->u
.p
.current_unit
->s
,
4165 length
, SEEK_CUR
) < 0)
4167 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
4170 length
= ((size_t) dtp
->u
.p
.current_unit
->recl
- max_pos
);
4173 p
= write_block (dtp
, length
);
4177 if (unlikely (is_char4_unit (dtp
)))
4179 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
4180 memset4 (p4
, ' ', length
);
4183 memset (p
, ' ', length
);
4185 /* Now that the current record has been padded out,
4186 determine where the next record in the array is.
4187 Note that this can return a negative value, so it
4188 needs to be assigned to a signed value. */
4189 gfc_offset record
= next_array_record
4190 (dtp
, dtp
->u
.p
.current_unit
->ls
, &finished
);
4192 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4194 /* Now seek to this record */
4195 record
= record
* dtp
->u
.p
.current_unit
->recl
;
4197 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
4199 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
4203 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
4209 /* If this is the last call to next_record move to the farthest
4210 position reached and set length to pad out the remainder
4211 of the record. (for character scaler unit) */
4214 m
= dtp
->u
.p
.current_unit
->recl
4215 - dtp
->u
.p
.current_unit
->bytes_left
;
4218 length
= max_pos
- m
;
4219 if (sseek (dtp
->u
.p
.current_unit
->s
,
4220 length
, SEEK_CUR
) < 0)
4222 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
4225 length
= (size_t) dtp
->u
.p
.current_unit
->recl
4229 length
= dtp
->u
.p
.current_unit
->bytes_left
;
4233 p
= write_block (dtp
, length
);
4237 if (unlikely (is_char4_unit (dtp
)))
4239 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
4240 memset4 (p4
, (gfc_char4_t
) ' ', length
);
4243 memset (p
, ' ', length
);
4247 else if (dtp
->u
.p
.seen_dollar
== 1)
4249 /* Handle legacy CARRIAGECONTROL line endings. */
4250 else if (dtp
->u
.p
.current_unit
->flags
.cc
== CC_FORTRAN
)
4251 next_record_cc (dtp
);
4254 /* Skip newlines for CC=CC_NONE. */
4255 const int len
= (dtp
->u
.p
.current_unit
->flags
.cc
== CC_NONE
)
4262 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
4263 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
4265 char *p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
4273 if (is_stream_io (dtp
))
4275 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
4276 if (dtp
->u
.p
.current_unit
->strm_pos
4277 < ssize (dtp
->u
.p
.current_unit
->s
))
4278 unit_truncate (dtp
->u
.p
.current_unit
,
4279 dtp
->u
.p
.current_unit
->strm_pos
- 1,
4285 case FORMATTED_UNSPECIFIED
:
4289 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
4294 /* Position to the next record, which means moving to the end of the
4295 current record. This can happen under several different
4296 conditions. If the done flag is not set, we get ready to process
4300 next_record (st_parameter_dt
*dtp
, int done
)
4302 gfc_offset fp
; /* File position. */
4304 dtp
->u
.p
.current_unit
->read_bad
= 0;
4306 if (dtp
->u
.p
.mode
== READING
)
4307 next_record_r (dtp
, done
);
4309 next_record_w (dtp
, done
);
4311 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
4313 if (!is_stream_io (dtp
))
4315 /* Since we have changed the position, set it to unspecified so
4316 that INQUIRE(POSITION=) knows it needs to look into it. */
4318 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_UNSPECIFIED
;
4320 dtp
->u
.p
.current_unit
->current_record
= 0;
4321 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
4323 fp
= stell (dtp
->u
.p
.current_unit
->s
);
4324 /* Calculate next record, rounding up partial records. */
4325 dtp
->u
.p
.current_unit
->last_record
=
4326 (fp
+ dtp
->u
.p
.current_unit
->recl
) /
4327 dtp
->u
.p
.current_unit
->recl
- 1;
4330 dtp
->u
.p
.current_unit
->last_record
++;
4336 smarkeor (dtp
->u
.p
.current_unit
->s
);
4340 /* Finalize the current data transfer. For a nonadvancing transfer,
4341 this means advancing to the next record. For internal units close the
4342 stream associated with the unit. */
4345 finalize_transfer (st_parameter_dt
*dtp
)
4347 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
4349 if ((dtp
->u
.p
.ionml
!= NULL
)
4350 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
4352 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
4354 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
4355 "Namelist formatting for unit connected "
4356 "with FORM='UNFORMATTED'");
4360 dtp
->u
.p
.namelist_mode
= 1;
4361 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
4362 namelist_read (dtp
);
4364 namelist_write (dtp
);
4367 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
4368 *dtp
->size
= dtp
->u
.p
.current_unit
->size_used
;
4370 if (dtp
->u
.p
.eor_condition
)
4372 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
4376 if (dtp
->u
.p
.current_unit
&& (dtp
->u
.p
.current_unit
->child_dtio
> 0))
4378 if (cf
& IOPARM_DT_HAS_FORMAT
)
4380 free (dtp
->u
.p
.fmt
);
4386 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
4388 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
4389 dtp
->u
.p
.current_unit
->current_record
= 0;
4393 dtp
->u
.p
.transfer
= NULL
;
4394 if (dtp
->u
.p
.current_unit
== NULL
)
4397 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
4399 finish_list_read (dtp
);
4403 if (dtp
->u
.p
.mode
== WRITING
)
4404 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
4405 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
4407 if (is_stream_io (dtp
))
4409 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
4410 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
4411 next_record (dtp
, 1);
4416 dtp
->u
.p
.current_unit
->current_record
= 0;
4418 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
4420 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
4421 dtp
->u
.p
.seen_dollar
= 0;
4425 /* For non-advancing I/O, save the current maximum position for use in the
4426 next I/O operation if needed. */
4427 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
4429 if (dtp
->u
.p
.skips
> 0)
4432 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
4433 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
4434 - dtp
->u
.p
.current_unit
->bytes_left
);
4436 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
4439 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
4440 - dtp
->u
.p
.current_unit
->bytes_left
);
4441 dtp
->u
.p
.current_unit
->saved_pos
=
4442 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
4443 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
4446 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
4447 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
4448 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
4450 dtp
->u
.p
.current_unit
->saved_pos
= 0;
4451 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
4452 next_record (dtp
, 1);
4456 if (dtp
->u
.p
.unit_is_internal
)
4458 /* The unit structure may be reused later so clear the
4459 internal unit kind. */
4460 dtp
->u
.p
.current_unit
->internal_unit_kind
= 0;
4462 fbuf_destroy (dtp
->u
.p
.current_unit
);
4463 if (dtp
->u
.p
.current_unit
4464 && (dtp
->u
.p
.current_unit
->child_dtio
== 0)
4465 && dtp
->u
.p
.current_unit
->s
)
4467 sclose (dtp
->u
.p
.current_unit
->s
);
4468 dtp
->u
.p
.current_unit
->s
= NULL
;
4472 #ifdef HAVE_POSIX_2008_LOCALE
4473 if (dtp
->u
.p
.old_locale
!= (locale_t
) 0)
4475 uselocale (dtp
->u
.p
.old_locale
);
4476 dtp
->u
.p
.old_locale
= (locale_t
) 0;
4479 __gthread_mutex_lock (&old_locale_lock
);
4480 if (!--old_locale_ctr
)
4482 setlocale (LC_NUMERIC
, old_locale
);
4485 __gthread_mutex_unlock (&old_locale_lock
);
4489 /* Transfer function for IOLENGTH. It doesn't actually do any
4490 data transfer, it just updates the length counter. */
4493 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
4494 void *dest
__attribute__ ((unused
)),
4495 int kind
__attribute__((unused
)),
4496 size_t size
, size_t nelems
)
4498 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
4499 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
4503 /* Initialize the IOLENGTH data transfer. This function is in essence
4504 a very much simplified version of data_transfer_init(), because it
4505 doesn't have to deal with units at all. */
4508 iolength_transfer_init (st_parameter_dt
*dtp
)
4510 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
4513 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
4515 /* Set up the subroutine that will handle the transfers. */
4517 dtp
->u
.p
.transfer
= iolength_transfer
;
4521 /* Library entry point for the IOLENGTH form of the INQUIRE
4522 statement. The IOLENGTH form requires no I/O to be performed, but
4523 it must still be a runtime library call so that we can determine
4524 the iolength for dynamic arrays and such. */
4526 extern void st_iolength (st_parameter_dt
*);
4527 export_proto(st_iolength
);
4530 st_iolength (st_parameter_dt
*dtp
)
4532 library_start (&dtp
->common
);
4533 iolength_transfer_init (dtp
);
4536 extern void st_iolength_done (st_parameter_dt
*);
4537 export_proto(st_iolength_done
);
4540 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
4547 /* The READ statement. */
4549 extern void st_read (st_parameter_dt
*);
4550 export_proto(st_read
);
4553 st_read (st_parameter_dt
*dtp
)
4555 library_start (&dtp
->common
);
4557 data_transfer_init (dtp
, 1);
4560 extern void st_read_done (st_parameter_dt
*);
4561 export_proto(st_read_done
);
4564 st_read_done_worker (st_parameter_dt
*dtp
, bool unlock
)
4566 bool free_newunit
= false;
4567 finalize_transfer (dtp
);
4571 /* If this is a parent READ statement we do not need to retain the
4572 internal unit structure for child use. */
4573 if (dtp
->u
.p
.current_unit
!= NULL
4574 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4576 if (dtp
->u
.p
.unit_is_internal
)
4578 if ((dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4580 free (dtp
->u
.p
.current_unit
->filename
);
4581 dtp
->u
.p
.current_unit
->filename
= NULL
;
4582 free (dtp
->u
.p
.current_unit
->ls
);
4583 dtp
->u
.p
.current_unit
->ls
= NULL
;
4585 free_newunit
= true;
4587 if (dtp
->u
.p
.unit_is_internal
|| dtp
->u
.p
.format_not_saved
)
4589 free_format_data (dtp
->u
.p
.fmt
);
4594 unlock_unit (dtp
->u
.p
.current_unit
);
4597 /* Avoid inverse lock issues by placing after unlock_unit. */
4598 WRLOCK (&unit_rwlock
);
4599 newunit_free (dtp
->common
.unit
);
4600 RWUNLOCK (&unit_rwlock
);
4605 st_read_done (st_parameter_dt
*dtp
)
4607 if (dtp
->u
.p
.current_unit
)
4609 if (dtp
->u
.p
.current_unit
->au
)
4611 if (dtp
->common
.flags
& IOPARM_DT_HAS_ID
)
4612 *dtp
->id
= enqueue_done_id (dtp
->u
.p
.current_unit
->au
, AIO_READ_DONE
);
4616 enqueue_done (dtp
->u
.p
.current_unit
->au
, AIO_READ_DONE
);
4618 unlock_unit (dtp
->u
.p
.current_unit
);
4621 st_read_done_worker (dtp
, true); /* Calls unlock_unit. */
4627 extern void st_write (st_parameter_dt
*);
4628 export_proto (st_write
);
4631 st_write (st_parameter_dt
*dtp
)
4633 library_start (&dtp
->common
);
4634 data_transfer_init (dtp
, 0);
4639 st_write_done_worker (st_parameter_dt
*dtp
, bool unlock
)
4641 bool free_newunit
= false;
4642 finalize_transfer (dtp
);
4644 if (dtp
->u
.p
.current_unit
!= NULL
4645 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4647 /* Deal with endfile conditions associated with sequential files. */
4648 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4649 switch (dtp
->u
.p
.current_unit
->endfile
)
4651 case AT_ENDFILE
: /* Remain at the endfile record. */
4655 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
4659 /* Get rid of whatever is after this record. */
4660 if (!is_internal_unit (dtp
))
4661 unit_truncate (dtp
->u
.p
.current_unit
,
4662 stell (dtp
->u
.p
.current_unit
->s
),
4664 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4670 /* If this is a parent WRITE statement we do not need to retain the
4671 internal unit structure for child use. */
4672 if (dtp
->u
.p
.unit_is_internal
)
4674 if ((dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4676 free (dtp
->u
.p
.current_unit
->filename
);
4677 dtp
->u
.p
.current_unit
->filename
= NULL
;
4678 free (dtp
->u
.p
.current_unit
->ls
);
4679 dtp
->u
.p
.current_unit
->ls
= NULL
;
4681 free_newunit
= true;
4683 if (dtp
->u
.p
.unit_is_internal
|| dtp
->u
.p
.format_not_saved
)
4685 free_format_data (dtp
->u
.p
.fmt
);
4690 unlock_unit (dtp
->u
.p
.current_unit
);
4693 /* Avoid inverse lock issues by placing after unlock_unit. */
4694 WRLOCK (&unit_rwlock
);
4695 newunit_free (dtp
->common
.unit
);
4696 RWUNLOCK (&unit_rwlock
);
4700 extern void st_write_done (st_parameter_dt
*);
4701 export_proto(st_write_done
);
4704 st_write_done (st_parameter_dt
*dtp
)
4706 if (dtp
->u
.p
.current_unit
)
4708 if (dtp
->u
.p
.current_unit
->au
&& dtp
->u
.p
.async
)
4710 if (dtp
->common
.flags
& IOPARM_DT_HAS_ID
)
4711 *dtp
->id
= enqueue_done_id (dtp
->u
.p
.current_unit
->au
,
4715 /* We perform synchronous I/O on an asynchronous unit, so no need
4716 to enqueue AIO_READ_DONE. */
4718 enqueue_done (dtp
->u
.p
.current_unit
->au
, AIO_WRITE_DONE
);
4720 unlock_unit (dtp
->u
.p
.current_unit
);
4723 st_write_done_worker (dtp
, true); /* Calls unlock_unit. */
4729 /* Wait operation. We need to keep around the do-nothing version
4730 of st_wait for compatibility with previous versions, which had marked
4731 the argument as unused (and thus liable to be removed).
4733 TODO: remove at next bump in version number. */
4736 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
4742 st_wait_async (st_parameter_wait
*wtp
)
4744 gfc_unit
*u
= find_unit (wtp
->common
.unit
);
4745 if (ASYNC_IO
&& u
&& u
->au
)
4747 if (wtp
->common
.flags
& IOPARM_WAIT_HAS_ID
)
4748 async_wait_id (&(wtp
->common
), u
->au
, *wtp
->id
);
4750 async_wait (&(wtp
->common
), u
->au
);
4757 /* Receives the scalar information for namelist objects and stores it
4758 in a linked list of namelist_info types. */
4761 set_nml_var (st_parameter_dt
*dtp
, void *var_addr
, char *var_name
,
4762 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4763 dtype_type dtype
, void *dtio_sub
, void *vtable
)
4765 namelist_info
*t1
= NULL
;
4767 size_t var_name_len
= strlen (var_name
);
4769 nml
= (namelist_info
*) xmalloc (sizeof (namelist_info
));
4771 nml
->mem_pos
= var_addr
;
4772 nml
->dtio_sub
= dtio_sub
;
4773 nml
->vtable
= vtable
;
4775 nml
->var_name
= (char*) xmalloc (var_name_len
+ 1);
4776 memcpy (nml
->var_name
, var_name
, var_name_len
);
4777 nml
->var_name
[var_name_len
] = '\0';
4779 nml
->len
= (int) len
;
4780 nml
->string_length
= (index_type
) string_length
;
4782 nml
->var_rank
= (int) (dtype
.rank
);
4783 nml
->size
= (index_type
) (dtype
.elem_len
);
4784 nml
->type
= (bt
) (dtype
.type
);
4786 if (nml
->var_rank
> 0)
4788 nml
->dim
= (descriptor_dimension
*)
4789 xmallocarray (nml
->var_rank
, sizeof (descriptor_dimension
));
4790 nml
->ls
= (array_loop_spec
*)
4791 xmallocarray (nml
->var_rank
, sizeof (array_loop_spec
));
4801 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
4803 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
4804 dtp
->u
.p
.ionml
= nml
;
4808 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
4813 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
4814 GFC_INTEGER_4
, gfc_charlen_type
, dtype_type
);
4815 export_proto(st_set_nml_var
);
4818 st_set_nml_var (st_parameter_dt
*dtp
, void *var_addr
, char *var_name
,
4819 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4822 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4827 /* Essentially the same as previous but carrying the dtio procedure
4828 and the vtable as additional arguments. */
4829 extern void st_set_nml_dtio_var (st_parameter_dt
*dtp
, void *, char *,
4830 GFC_INTEGER_4
, gfc_charlen_type
, dtype_type
,
4832 export_proto(st_set_nml_dtio_var
);
4836 st_set_nml_dtio_var (st_parameter_dt
*dtp
, void *var_addr
, char *var_name
,
4837 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4838 dtype_type dtype
, void *dtio_sub
, void *vtable
)
4840 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4841 dtype
, dtio_sub
, vtable
);
4844 /* Store the dimensional information for the namelist object. */
4845 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
4846 index_type
, index_type
,
4848 export_proto(st_set_nml_var_dim
);
4851 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
4852 index_type stride
, index_type lbound
,
4860 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
4862 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
4866 /* Once upon a time, a poor innocent Fortran program was reading a
4867 file, when suddenly it hit the end-of-file (EOF). Unfortunately
4868 the OS doesn't tell whether we're at the EOF or whether we already
4869 went past it. Luckily our hero, libgfortran, keeps track of this.
4870 Call this function when you detect an EOF condition. See Section
4874 hit_eof (st_parameter_dt
*dtp
)
4876 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
4878 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4879 switch (dtp
->u
.p
.current_unit
->endfile
)
4883 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4884 if (!is_internal_unit (dtp
) && !dtp
->u
.p
.namelist_mode
)
4886 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
4887 dtp
->u
.p
.current_unit
->current_record
= 0;
4890 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4894 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
4895 dtp
->u
.p
.current_unit
->current_record
= 0;
4900 /* Non-sequential files don't have an ENDFILE record, so we
4901 can't be at AFTER_ENDFILE. */
4902 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4903 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4904 dtp
->u
.p
.current_unit
->current_record
= 0;