1 /* Copyright (C) 2002-2017 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist transfer functions contributed by Paul Thomas
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
28 /* transfer.c -- Top level handling of data transfer statements. */
38 /* Calling conventions: Data transfer statements are unlike other
39 library calls in that they extend over several calls.
41 The first call is always a call to st_read() or st_write(). These
42 subroutines return no status unless a namelist read or write is
43 being done, in which case there is the usual status. No further
44 calls are necessary in this case.
46 For other sorts of data transfer, there are zero or more data
47 transfer statement that depend on the format of the data transfer
48 statement. For READ (and for backwards compatibily: for WRITE), one has
53 transfer_character_wide
61 transfer_integer_write
62 transfer_logical_write
63 transfer_character_write
64 transfer_character_wide_write
66 transfer_complex_write
67 transfer_real128_write
68 transfer_complex128_write
70 These subroutines do not return status. The *128 functions
71 are in the file transfer128.c.
73 The last call is a call to st_[read|write]_done(). While
74 something can easily go wrong with the initial st_read() or
75 st_write(), an error inhibits any data from actually being
78 extern void transfer_integer (st_parameter_dt
*, void *, int);
79 export_proto(transfer_integer
);
81 extern void transfer_integer_write (st_parameter_dt
*, void *, int);
82 export_proto(transfer_integer_write
);
84 extern void transfer_real (st_parameter_dt
*, void *, int);
85 export_proto(transfer_real
);
87 extern void transfer_real_write (st_parameter_dt
*, void *, int);
88 export_proto(transfer_real_write
);
90 extern void transfer_logical (st_parameter_dt
*, void *, int);
91 export_proto(transfer_logical
);
93 extern void transfer_logical_write (st_parameter_dt
*, void *, int);
94 export_proto(transfer_logical_write
);
96 extern void transfer_character (st_parameter_dt
*, void *, int);
97 export_proto(transfer_character
);
99 extern void transfer_character_write (st_parameter_dt
*, void *, int);
100 export_proto(transfer_character_write
);
102 extern void transfer_character_wide (st_parameter_dt
*, void *, int, int);
103 export_proto(transfer_character_wide
);
105 extern void transfer_character_wide_write (st_parameter_dt
*,
107 export_proto(transfer_character_wide_write
);
109 extern void transfer_complex (st_parameter_dt
*, void *, int);
110 export_proto(transfer_complex
);
112 extern void transfer_complex_write (st_parameter_dt
*, void *, int);
113 export_proto(transfer_complex_write
);
115 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
117 export_proto(transfer_array
);
119 extern void transfer_array_write (st_parameter_dt
*, gfc_array_char
*, int,
121 export_proto(transfer_array_write
);
123 /* User defined derived type input/output. */
125 transfer_derived (st_parameter_dt
*dtp
, void *dtio_source
, void *dtio_proc
);
126 export_proto(transfer_derived
);
129 transfer_derived_write (st_parameter_dt
*dtp
, void *dtio_source
, void *dtio_proc
);
130 export_proto(transfer_derived_write
);
132 static void us_read (st_parameter_dt
*, int);
133 static void us_write (st_parameter_dt
*, int);
134 static void next_record_r_unf (st_parameter_dt
*, int);
135 static void next_record_w_unf (st_parameter_dt
*, int);
137 static const st_option advance_opt
[] = {
138 {"yes", ADVANCE_YES
},
144 static const st_option decimal_opt
[] = {
145 {"point", DECIMAL_POINT
},
146 {"comma", DECIMAL_COMMA
},
150 static const st_option round_opt
[] = {
152 {"down", ROUND_DOWN
},
153 {"zero", ROUND_ZERO
},
154 {"nearest", ROUND_NEAREST
},
155 {"compatible", ROUND_COMPATIBLE
},
156 {"processor_defined", ROUND_PROCDEFINED
},
161 static const st_option sign_opt
[] = {
163 {"suppress", SIGN_SS
},
164 {"processor_defined", SIGN_S
},
168 static const st_option blank_opt
[] = {
169 {"null", BLANK_NULL
},
170 {"zero", BLANK_ZERO
},
174 static const st_option delim_opt
[] = {
175 {"apostrophe", DELIM_APOSTROPHE
},
176 {"quote", DELIM_QUOTE
},
177 {"none", DELIM_NONE
},
181 static const st_option pad_opt
[] = {
188 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
189 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
195 current_mode (st_parameter_dt
*dtp
)
199 m
= FORM_UNSPECIFIED
;
201 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
203 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
204 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
206 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
208 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
209 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
211 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
213 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
214 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
221 /* Mid level data transfer statements. */
223 /* Read sequential file - internal unit */
226 read_sf_internal (st_parameter_dt
*dtp
, int * length
)
228 static char *empty_string
[0];
232 /* Zero size array gives internal unit len of 0. Nothing to read. */
233 if (dtp
->internal_unit_len
== 0
234 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
237 /* If we have seen an eor previously, return a length of 0. The
238 caller is responsible for correctly padding the input field. */
239 if (dtp
->u
.p
.sf_seen_eor
)
242 /* Just return something that isn't a NULL pointer, otherwise the
243 caller thinks an error occurred. */
244 return (char*) empty_string
;
248 if (is_char4_unit(dtp
))
251 gfc_char4_t
*p
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
,
253 base
= fbuf_alloc (dtp
->u
.p
.current_unit
, lorig
);
254 for (i
= 0; i
< *length
; i
++, p
++)
255 base
[i
] = *p
> 255 ? '?' : (unsigned char) *p
;
258 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
260 if (unlikely (lorig
> *length
))
266 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
268 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
269 dtp
->u
.p
.current_unit
->has_size
)
270 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *length
;
276 /* When reading sequential formatted records we have a problem. We
277 don't know how long the line is until we read the trailing newline,
278 and we don't want to read too much. If we read too much, we might
279 have to do a physical seek backwards depending on how much data is
280 present, and devices like terminals aren't seekable and would cause
283 Given this, the solution is to read a byte at a time, stopping if
284 we hit the newline. For small allocations, we use a static buffer.
285 For larger allocations, we are forced to allocate memory on the
286 heap. Hopefully this won't happen very often. */
288 /* Read sequential file - external unit */
291 read_sf (st_parameter_dt
*dtp
, int * length
)
293 static char *empty_string
[0];
295 int n
, lorig
, seen_comma
;
297 /* If we have seen an eor previously, return a length of 0. The
298 caller is responsible for correctly padding the input field. */
299 if (dtp
->u
.p
.sf_seen_eor
)
302 /* Just return something that isn't a NULL pointer, otherwise the
303 caller thinks an error occurred. */
304 return (char*) empty_string
;
309 /* Read data into format buffer and scan through it. */
314 q
= fbuf_getc (dtp
->u
.p
.current_unit
);
317 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
318 && (q
== '\n' || q
== '\r'))
320 /* Unexpected end of line. Set the position. */
321 dtp
->u
.p
.sf_seen_eor
= 1;
323 /* If we see an EOR during non-advancing I/O, we need to skip
324 the rest of the I/O statement. Set the corresponding flag. */
325 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
326 dtp
->u
.p
.eor_condition
= 1;
328 /* If we encounter a CR, it might be a CRLF. */
329 if (q
== '\r') /* Probably a CRLF */
331 /* See if there is an LF. */
332 q2
= fbuf_getc (dtp
->u
.p
.current_unit
);
334 dtp
->u
.p
.sf_seen_eor
= 2;
335 else if (q2
!= EOF
) /* Oops, seek back. */
336 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
339 /* Without padding, terminate the I/O statement without assigning
340 the value. With padding, the value still needs to be assigned,
341 so we can just continue with a short read. */
342 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
344 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
351 /* Short circuit the read if a comma is found during numeric input.
352 The flag is set to zero during character reads so that commas in
353 strings are not ignored */
355 if (dtp
->u
.p
.sf_read_comma
== 1)
358 notify_std (&dtp
->common
, GFC_STD_GNU
,
359 "Comma in formatted numeric read.");
367 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
368 some other stuff. Set the relevant flags. */
369 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
373 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
375 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
381 dtp
->u
.p
.eor_condition
= 1;
386 else if (dtp
->u
.p
.advance_status
== ADVANCE_NO
387 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
388 || dtp
->u
.p
.current_unit
->bytes_left
389 == dtp
->u
.p
.current_unit
->recl
)
398 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
400 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
401 dtp
->u
.p
.current_unit
->has_size
)
402 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) n
;
404 /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
405 fbuf_getc might reallocate the buffer. So return current pointer
406 minus all the advances, which is n plus up to two characters
407 of newline or comma. */
408 return fbuf_getptr (dtp
->u
.p
.current_unit
)
409 - n
- dtp
->u
.p
.sf_seen_eor
- seen_comma
;
413 /* Function for reading the next couple of bytes from the current
414 file, advancing the current position. We return NULL on end of record or
415 end of file. This function is only for formatted I/O, unformatted uses
418 If the read is short, then it is because the current record does not
419 have enough data to satisfy the read request and the file was
420 opened with PAD=YES. The caller must assume tailing spaces for
424 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
429 if (!is_stream_io (dtp
))
431 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
433 /* For preconnected units with default record length, set bytes left
434 to unit record length and proceed, otherwise error. */
435 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
436 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
437 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
440 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
441 && !is_internal_unit (dtp
))
443 /* Not enough data left. */
444 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
449 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0
450 && !is_internal_unit(dtp
)))
456 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
460 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
461 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
462 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
464 if (is_internal_unit (dtp
))
465 source
= read_sf_internal (dtp
, nbytes
);
467 source
= read_sf (dtp
, nbytes
);
469 dtp
->u
.p
.current_unit
->strm_pos
+=
470 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
474 /* If we reach here, we can assume it's direct access. */
476 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
479 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
480 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
482 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
483 dtp
->u
.p
.current_unit
->has_size
)
484 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *nbytes
;
486 if (norig
!= *nbytes
)
488 /* Short read, this shouldn't happen. */
489 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
491 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
496 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
502 /* Read a block from a character(kind=4) internal unit, to be transferred into
503 a character(kind=4) variable. Note: Portions of this code borrowed from
506 read_block_form4 (st_parameter_dt
*dtp
, int * nbytes
)
508 static gfc_char4_t
*empty_string
[0];
512 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
513 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
515 /* Zero size array gives internal unit len of 0. Nothing to read. */
516 if (dtp
->internal_unit_len
== 0
517 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
520 /* If we have seen an eor previously, return a length of 0. The
521 caller is responsible for correctly padding the input field. */
522 if (dtp
->u
.p
.sf_seen_eor
)
525 /* Just return something that isn't a NULL pointer, otherwise the
526 caller thinks an error occurred. */
531 source
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
, nbytes
);
533 if (unlikely (lorig
> *nbytes
))
539 dtp
->u
.p
.current_unit
->bytes_left
-= *nbytes
;
541 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
542 dtp
->u
.p
.current_unit
->has_size
)
543 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *nbytes
;
549 /* Reads a block directly into application data space. This is for
550 unformatted files. */
553 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
555 ssize_t to_read_record
;
556 ssize_t have_read_record
;
557 ssize_t to_read_subrecord
;
558 ssize_t have_read_subrecord
;
561 if (is_stream_io (dtp
))
563 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
565 if (unlikely (have_read_record
< 0))
567 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
571 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
573 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
575 /* Short read, e.g. if we hit EOF. For stream files,
576 we have to set the end-of-file condition. */
582 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
584 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
587 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
588 nbytes
= to_read_record
;
593 to_read_record
= nbytes
;
596 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
598 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
599 if (unlikely (to_read_record
< 0))
601 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
605 if (to_read_record
!= (ssize_t
) nbytes
)
607 /* Short read, e.g. if we hit EOF. Apparently, we read
608 more than was written to the last record. */
612 if (unlikely (short_record
))
614 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
619 /* Unformatted sequential. We loop over the subrecords, reading
620 until the request has been fulfilled or the record has run out
621 of continuation subrecords. */
623 /* Check whether we exceed the total record length. */
625 if (dtp
->u
.p
.current_unit
->flags
.has_recl
626 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
628 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
633 to_read_record
= nbytes
;
636 have_read_record
= 0;
640 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
641 < (gfc_offset
) to_read_record
)
643 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
644 to_read_record
-= to_read_subrecord
;
648 to_read_subrecord
= to_read_record
;
652 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
654 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
655 buf
+ have_read_record
, to_read_subrecord
);
656 if (unlikely (have_read_subrecord
< 0))
658 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
662 have_read_record
+= have_read_subrecord
;
664 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
666 /* Short read, e.g. if we hit EOF. This means the record
667 structure has been corrupted, or the trailing record
668 marker would still be present. */
670 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
674 if (to_read_record
> 0)
676 if (likely (dtp
->u
.p
.current_unit
->continued
))
678 next_record_r_unf (dtp
, 0);
683 /* Let's make sure the file position is correctly pre-positioned
684 for the next read statement. */
686 dtp
->u
.p
.current_unit
->current_record
= 0;
687 next_record_r_unf (dtp
, 0);
688 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
694 /* Normal exit, the read request has been fulfilled. */
699 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
700 if (unlikely (short_record
))
702 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
709 /* Function for writing a block of bytes to the current file at the
710 current position, advancing the file pointer. We are given a length
711 and return a pointer to a buffer that the caller must (completely)
712 fill in. Returns NULL on error. */
715 write_block (st_parameter_dt
*dtp
, int length
)
719 if (!is_stream_io (dtp
))
721 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
723 /* For preconnected units with default record length, set bytes left
724 to unit record length and proceed, otherwise error. */
725 if (likely ((dtp
->u
.p
.current_unit
->unit_number
726 == options
.stdout_unit
727 || dtp
->u
.p
.current_unit
->unit_number
728 == options
.stderr_unit
)
729 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
730 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
733 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
738 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
741 if (is_internal_unit (dtp
))
743 if (is_char4_unit(dtp
)) /* char4 internel unit. */
746 dest4
= mem_alloc_w4 (dtp
->u
.p
.current_unit
->s
, &length
);
749 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
755 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
759 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
763 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
764 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
768 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
771 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
776 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
777 dtp
->u
.p
.current_unit
->has_size
)
778 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) length
;
780 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
786 /* High level interface to swrite(), taking care of errors. This is only
787 called for unformatted files. There are three cases to consider:
788 Stream I/O, unformatted direct, unformatted sequential. */
791 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
794 ssize_t have_written
;
795 ssize_t to_write_subrecord
;
800 if (is_stream_io (dtp
))
802 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
803 if (unlikely (have_written
< 0))
805 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
809 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
814 /* Unformatted direct access. */
816 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
818 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
820 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
824 if (buf
== NULL
&& nbytes
== 0)
827 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
828 if (unlikely (have_written
< 0))
830 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
834 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
835 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
840 /* Unformatted sequential. */
844 if (dtp
->u
.p
.current_unit
->flags
.has_recl
845 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
847 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
859 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
860 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
862 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
863 (gfc_offset
) to_write_subrecord
;
865 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
866 buf
+ have_written
, to_write_subrecord
);
867 if (unlikely (to_write_subrecord
< 0))
869 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
873 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
874 nbytes
-= to_write_subrecord
;
875 have_written
+= to_write_subrecord
;
880 next_record_w_unf (dtp
, 1);
883 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
884 if (unlikely (short_record
))
886 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
893 /* Reverse memcpy - used for byte swapping. */
896 reverse_memcpy (void *dest
, const void *src
, size_t n
)
902 s
= (char *) src
+ n
- 1;
904 /* Write with ascending order - this is likely faster
905 on modern architectures because of write combining. */
911 /* Utility function for byteswapping an array, using the bswap
912 builtins if possible. dest and src can overlap completely, or then
913 they must point to separate objects; partial overlaps are not
917 bswap_array (void *dest
, const void *src
, size_t size
, size_t nelems
)
927 for (size_t i
= 0; i
< nelems
; i
++)
928 ((uint16_t*)dest
)[i
] = __builtin_bswap16 (((uint16_t*)src
)[i
]);
931 for (size_t i
= 0; i
< nelems
; i
++)
932 ((uint32_t*)dest
)[i
] = __builtin_bswap32 (((uint32_t*)src
)[i
]);
935 for (size_t i
= 0; i
< nelems
; i
++)
936 ((uint64_t*)dest
)[i
] = __builtin_bswap64 (((uint64_t*)src
)[i
]);
941 for (size_t i
= 0; i
< nelems
; i
++)
944 memcpy (&tmp
, ps
, 4);
945 *(uint32_t*)pd
= __builtin_bswap32 (*(uint32_t*)(ps
+ 8));
946 *(uint32_t*)(pd
+ 4) = __builtin_bswap32 (*(uint32_t*)(ps
+ 4));
947 *(uint32_t*)(pd
+ 8) = __builtin_bswap32 (tmp
);
955 for (size_t i
= 0; i
< nelems
; i
++)
958 memcpy (&tmp
, ps
, 8);
959 *(uint64_t*)pd
= __builtin_bswap64 (*(uint64_t*)(ps
+ 8));
960 *(uint64_t*)(pd
+ 8) = __builtin_bswap64 (tmp
);
970 for (size_t i
= 0; i
< nelems
; i
++)
972 reverse_memcpy (pd
, ps
, size
);
979 /* In-place byte swap. */
980 for (size_t i
= 0; i
< nelems
; i
++)
982 char tmp
, *low
= pd
, *high
= pd
+ size
- 1;
983 for (size_t j
= 0; j
< size
/2; j
++)
998 /* Master function for unformatted reads. */
1001 unformatted_read (st_parameter_dt
*dtp
, bt type
,
1002 void *dest
, int kind
, size_t size
, size_t nelems
)
1004 if (type
== BT_CLASS
)
1006 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1007 char tmp_iomsg
[IOMSG_LEN
] = "";
1009 gfc_charlen_type child_iomsg_len
;
1011 int *child_iostat
= NULL
;
1013 /* Set iostat, intent(out). */
1015 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1016 dtp
->common
.iostat
: &noiostat
;
1018 /* Set iomsg, intent(inout). */
1019 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1021 child_iomsg
= dtp
->common
.iomsg
;
1022 child_iomsg_len
= dtp
->common
.iomsg_len
;
1026 child_iomsg
= tmp_iomsg
;
1027 child_iomsg_len
= IOMSG_LEN
;
1030 /* Call the user defined unformatted READ procedure. */
1031 dtp
->u
.p
.current_unit
->child_dtio
++;
1032 dtp
->u
.p
.ufdtio_ptr (dest
, &unit
, child_iostat
, child_iomsg
,
1034 dtp
->u
.p
.current_unit
->child_dtio
--;
1038 if (type
== BT_CHARACTER
)
1039 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
1040 read_block_direct (dtp
, dest
, size
* nelems
);
1042 if (unlikely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_SWAP
)
1045 /* Handle wide chracters. */
1046 if (type
== BT_CHARACTER
)
1052 /* Break up complex into its constituent reals. */
1053 else if (type
== BT_COMPLEX
)
1058 bswap_array (dest
, dest
, size
, nelems
);
1063 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
1064 bytes on 64 bit machines. The unused bytes are not initialized and never
1065 used, which can show an error with memory checking analyzers like
1066 valgrind. We us BT_CLASS to denote a User Defined I/O call. */
1069 unformatted_write (st_parameter_dt
*dtp
, bt type
,
1070 void *source
, int kind
, size_t size
, size_t nelems
)
1072 if (type
== BT_CLASS
)
1074 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1075 char tmp_iomsg
[IOMSG_LEN
] = "";
1077 gfc_charlen_type child_iomsg_len
;
1079 int *child_iostat
= NULL
;
1081 /* Set iostat, intent(out). */
1083 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1084 dtp
->common
.iostat
: &noiostat
;
1086 /* Set iomsg, intent(inout). */
1087 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1089 child_iomsg
= dtp
->common
.iomsg
;
1090 child_iomsg_len
= dtp
->common
.iomsg_len
;
1094 child_iomsg
= tmp_iomsg
;
1095 child_iomsg_len
= IOMSG_LEN
;
1098 /* Call the user defined unformatted WRITE procedure. */
1099 dtp
->u
.p
.current_unit
->child_dtio
++;
1100 dtp
->u
.p
.ufdtio_ptr (source
, &unit
, child_iostat
, child_iomsg
,
1102 dtp
->u
.p
.current_unit
->child_dtio
--;
1106 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1109 size_t stride
= type
== BT_CHARACTER
?
1110 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1112 write_buf (dtp
, source
, stride
* nelems
);
1116 #define BSWAP_BUFSZ 512
1117 char buffer
[BSWAP_BUFSZ
];
1123 /* Handle wide chracters. */
1124 if (type
== BT_CHARACTER
&& kind
!= 1)
1130 /* Break up complex into its constituent reals. */
1131 if (type
== BT_COMPLEX
)
1137 /* By now, all complex variables have been split into their
1138 constituent reals. */
1144 if (size
* nrem
> BSWAP_BUFSZ
)
1145 nc
= BSWAP_BUFSZ
/ size
;
1149 bswap_array (buffer
, p
, size
, nc
);
1150 write_buf (dtp
, buffer
, size
* nc
);
1159 /* Return a pointer to the name of a type. */
1184 p
= "CLASS or DERIVED";
1187 internal_error (NULL
, "type_name(): Bad type");
1194 /* Write a constant string to the output.
1195 This is complicated because the string can have doubled delimiters
1196 in it. The length in the format node is the true length. */
1199 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
1201 char c
, delimiter
, *p
, *q
;
1204 length
= f
->u
.string
.length
;
1208 p
= write_block (dtp
, length
);
1215 for (; length
> 0; length
--)
1218 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
1219 q
++; /* Skip the doubled delimiter. */
1224 /* Given actual and expected types in a formatted data transfer, make
1225 sure they agree. If not, an error message is generated. Returns
1226 nonzero if something went wrong. */
1229 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
1232 char buffer
[BUFLEN
];
1234 if (actual
== expected
)
1237 /* Adjust item_count before emitting error message. */
1238 snprintf (buffer
, BUFLEN
,
1239 "Expected %s for item %d in formatted transfer, got %s",
1240 type_name (expected
), dtp
->u
.p
.item_count
- 1, type_name (actual
));
1242 format_error (dtp
, f
, buffer
);
1247 /* Check that the dtio procedure required for formatted IO is present. */
1250 check_dtio_proc (st_parameter_dt
*dtp
, const fnode
*f
)
1252 char buffer
[BUFLEN
];
1254 if (dtp
->u
.p
.fdtio_ptr
!= NULL
)
1257 snprintf (buffer
, BUFLEN
,
1258 "Missing DTIO procedure or intrinsic type passed for item %d "
1259 "in formatted transfer",
1260 dtp
->u
.p
.item_count
- 1);
1262 format_error (dtp
, f
, buffer
);
1268 require_numeric_type (st_parameter_dt
*dtp
, bt actual
, const fnode
*f
)
1271 char buffer
[BUFLEN
];
1273 if (actual
== BT_INTEGER
|| actual
== BT_REAL
|| actual
== BT_COMPLEX
)
1276 /* Adjust item_count before emitting error message. */
1277 snprintf (buffer
, BUFLEN
,
1278 "Expected numeric type for item %d in formatted transfer, got %s",
1279 dtp
->u
.p
.item_count
- 1, type_name (actual
));
1281 format_error (dtp
, f
, buffer
);
1286 get_dt_format (char *p
, gfc_charlen_type
*length
)
1288 char delim
= p
[-1]; /* The delimiter is always the first character back. */
1290 gfc_charlen_type len
= *length
; /* This length already correct, less 'DT'. */
1292 res
= q
= xmalloc (len
+ 2);
1294 /* Set the beginning of the string to 'DT', length adjusted below. */
1298 /* The string may contain doubled quotes so scan and skip as needed. */
1299 for (; len
> 0; len
--)
1303 p
++; /* Skip the doubled delimiter. */
1306 /* Adjust the string length by two now that we are done. */
1313 /* This function is in the main loop for a formatted data transfer
1314 statement. It would be natural to implement this as a coroutine
1315 with the user program, but C makes that awkward. We loop,
1316 processing format elements. When we actually have to transfer
1317 data instead of just setting flags, we return control to the user
1318 program which calls a function that supplies the address and type
1319 of the next element, then comes back here to process it. */
1322 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1325 int pos
, bytes_used
;
1329 int consume_data_flag
;
1331 /* Change a complex data item into a pair of reals. */
1333 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1334 if (type
== BT_COMPLEX
)
1340 /* If there's an EOR condition, we simulate finalizing the transfer
1341 by doing nothing. */
1342 if (dtp
->u
.p
.eor_condition
)
1345 /* Set this flag so that commas in reads cause the read to complete before
1346 the entire field has been read. The next read field will start right after
1347 the comma in the stream. (Set to 0 for character reads). */
1348 dtp
->u
.p
.sf_read_comma
=
1349 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1353 /* If reversion has occurred and there is another real data item,
1354 then we have to move to the next record. */
1355 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1357 dtp
->u
.p
.reversion_flag
= 0;
1358 next_record (dtp
, 0);
1361 consume_data_flag
= 1;
1362 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1365 f
= next_format (dtp
);
1368 /* No data descriptors left. */
1369 if (unlikely (n
> 0))
1370 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1371 "Insufficient data descriptors in format after reversion");
1377 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1378 - dtp
->u
.p
.current_unit
->bytes_left
);
1380 if (is_stream_io(dtp
))
1387 goto need_read_data
;
1388 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1390 read_decimal (dtp
, f
, p
, kind
);
1395 goto need_read_data
;
1396 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1397 && require_numeric_type (dtp
, type
, f
))
1399 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1400 && require_type (dtp
, BT_INTEGER
, type
, f
))
1402 read_radix (dtp
, f
, p
, kind
, 2);
1407 goto need_read_data
;
1408 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1409 && require_numeric_type (dtp
, type
, f
))
1411 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1412 && require_type (dtp
, BT_INTEGER
, type
, f
))
1414 read_radix (dtp
, f
, p
, kind
, 8);
1419 goto need_read_data
;
1420 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1421 && require_numeric_type (dtp
, type
, f
))
1423 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1424 && require_type (dtp
, BT_INTEGER
, type
, f
))
1426 read_radix (dtp
, f
, p
, kind
, 16);
1431 goto need_read_data
;
1433 /* It is possible to have FMT_A with something not BT_CHARACTER such
1434 as when writing out hollerith strings, so check both type
1435 and kind before calling wide character routines. */
1436 if (type
== BT_CHARACTER
&& kind
== 4)
1437 read_a_char4 (dtp
, f
, p
, size
);
1439 read_a (dtp
, f
, p
, size
);
1444 goto need_read_data
;
1445 read_l (dtp
, f
, p
, kind
);
1450 goto need_read_data
;
1451 if (require_type (dtp
, BT_REAL
, type
, f
))
1453 read_f (dtp
, f
, p
, kind
);
1458 goto need_read_data
;
1460 if (check_dtio_proc (dtp
, f
))
1462 if (require_type (dtp
, BT_CLASS
, type
, f
))
1464 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1466 char tmp_iomsg
[IOMSG_LEN
] = "";
1468 gfc_charlen_type child_iomsg_len
;
1470 int *child_iostat
= NULL
;
1472 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1474 /* Build the iotype string. */
1475 if (iotype_len
== 0)
1481 iotype
= get_dt_format (f
->u
.udf
.string
, &iotype_len
);
1483 /* Set iostat, intent(out). */
1485 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1486 dtp
->common
.iostat
: &noiostat
;
1488 /* Set iomsg, intent(inout). */
1489 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1491 child_iomsg
= dtp
->common
.iomsg
;
1492 child_iomsg_len
= dtp
->common
.iomsg_len
;
1496 child_iomsg
= tmp_iomsg
;
1497 child_iomsg_len
= IOMSG_LEN
;
1500 /* Call the user defined formatted READ procedure. */
1501 dtp
->u
.p
.current_unit
->child_dtio
++;
1502 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1503 child_iostat
, child_iomsg
,
1504 iotype_len
, child_iomsg_len
);
1505 dtp
->u
.p
.current_unit
->child_dtio
--;
1507 if (f
->u
.udf
.string_len
!= 0)
1509 /* Note: vlist is freed in free_format_data. */
1514 goto need_read_data
;
1515 if (require_type (dtp
, BT_REAL
, type
, f
))
1517 read_f (dtp
, f
, p
, kind
);
1522 goto need_read_data
;
1523 if (require_type (dtp
, BT_REAL
, type
, f
))
1525 read_f (dtp
, f
, p
, kind
);
1530 goto need_read_data
;
1531 if (require_type (dtp
, BT_REAL
, type
, f
))
1533 read_f (dtp
, f
, p
, kind
);
1538 goto need_read_data
;
1539 if (require_type (dtp
, BT_REAL
, type
, f
))
1541 read_f (dtp
, f
, p
, kind
);
1546 goto need_read_data
;
1550 read_decimal (dtp
, f
, p
, kind
);
1553 read_l (dtp
, f
, p
, kind
);
1557 read_a_char4 (dtp
, f
, p
, size
);
1559 read_a (dtp
, f
, p
, size
);
1562 read_f (dtp
, f
, p
, kind
);
1565 internal_error (&dtp
->common
, "formatted_transfer(): Bad type");
1570 consume_data_flag
= 0;
1571 format_error (dtp
, f
, "Constant string in input format");
1574 /* Format codes that don't transfer data. */
1577 consume_data_flag
= 0;
1578 dtp
->u
.p
.skips
+= f
->u
.n
;
1579 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1580 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1581 read_x (dtp
, f
->u
.n
);
1586 consume_data_flag
= 0;
1588 if (f
->format
== FMT_TL
)
1590 /* Handle the special case when no bytes have been used yet.
1591 Cannot go below zero. */
1592 if (bytes_used
== 0)
1594 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1595 dtp
->u
.p
.skips
-= f
->u
.n
;
1596 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1599 pos
= bytes_used
- f
->u
.n
;
1604 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1605 left tab limit. We do not check if the position has gone
1606 beyond the end of record because a subsequent tab could
1607 bring us back again. */
1608 pos
= pos
< 0 ? 0 : pos
;
1610 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1611 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1612 + pos
- dtp
->u
.p
.max_pos
;
1613 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1614 ? 0 : dtp
->u
.p
.pending_spaces
;
1615 if (dtp
->u
.p
.skips
== 0)
1618 /* Adjust everything for end-of-record condition */
1619 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1621 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1622 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1624 if (dtp
->u
.p
.pending_spaces
== 0)
1625 dtp
->u
.p
.sf_seen_eor
= 0;
1627 if (dtp
->u
.p
.skips
< 0)
1629 if (is_internal_unit (dtp
))
1630 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1632 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1633 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1634 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1637 read_x (dtp
, dtp
->u
.p
.skips
);
1641 consume_data_flag
= 0;
1642 dtp
->u
.p
.sign_status
= SIGN_S
;
1646 consume_data_flag
= 0;
1647 dtp
->u
.p
.sign_status
= SIGN_SS
;
1651 consume_data_flag
= 0;
1652 dtp
->u
.p
.sign_status
= SIGN_SP
;
1656 consume_data_flag
= 0 ;
1657 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1661 consume_data_flag
= 0;
1662 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1666 consume_data_flag
= 0;
1667 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1671 consume_data_flag
= 0;
1672 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1676 consume_data_flag
= 0;
1677 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1681 consume_data_flag
= 0;
1682 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1686 consume_data_flag
= 0;
1687 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1691 consume_data_flag
= 0;
1692 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1696 consume_data_flag
= 0;
1697 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1701 consume_data_flag
= 0;
1702 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1706 consume_data_flag
= 0;
1707 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1711 consume_data_flag
= 0;
1712 dtp
->u
.p
.seen_dollar
= 1;
1716 consume_data_flag
= 0;
1717 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1718 next_record (dtp
, 0);
1722 /* A colon descriptor causes us to exit this loop (in
1723 particular preventing another / descriptor from being
1724 processed) unless there is another data item to be
1726 consume_data_flag
= 0;
1732 internal_error (&dtp
->common
, "Bad format node");
1735 /* Adjust the item count and data pointer. */
1737 if ((consume_data_flag
> 0) && (n
> 0))
1740 p
= ((char *) p
) + size
;
1745 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1746 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1751 /* Come here when we need a data descriptor but don't have one. We
1752 push the current format node back onto the input, then return and
1753 let the user program call us back with the data. */
1755 unget_format (dtp
, f
);
1760 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1763 int pos
, bytes_used
;
1767 int consume_data_flag
;
1769 /* Change a complex data item into a pair of reals. */
1771 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1772 if (type
== BT_COMPLEX
)
1778 /* If there's an EOR condition, we simulate finalizing the transfer
1779 by doing nothing. */
1780 if (dtp
->u
.p
.eor_condition
)
1783 /* Set this flag so that commas in reads cause the read to complete before
1784 the entire field has been read. The next read field will start right after
1785 the comma in the stream. (Set to 0 for character reads). */
1786 dtp
->u
.p
.sf_read_comma
=
1787 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1791 /* If reversion has occurred and there is another real data item,
1792 then we have to move to the next record. */
1793 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1795 dtp
->u
.p
.reversion_flag
= 0;
1796 next_record (dtp
, 0);
1799 consume_data_flag
= 1;
1800 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1803 f
= next_format (dtp
);
1806 /* No data descriptors left. */
1807 if (unlikely (n
> 0))
1808 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1809 "Insufficient data descriptors in format after reversion");
1813 /* Now discharge T, TR and X movements to the right. This is delayed
1814 until a data producing format to suppress trailing spaces. */
1817 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1818 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1819 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1820 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1821 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
1823 || t
== FMT_STRING
))
1825 if (dtp
->u
.p
.skips
> 0)
1828 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1829 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1830 - dtp
->u
.p
.current_unit
->bytes_left
);
1832 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1835 if (dtp
->u
.p
.skips
< 0)
1837 if (is_internal_unit (dtp
))
1838 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1840 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1841 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1843 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1846 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1847 - dtp
->u
.p
.current_unit
->bytes_left
);
1849 if (is_stream_io(dtp
))
1857 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1859 write_i (dtp
, f
, p
, kind
);
1865 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1866 && require_numeric_type (dtp
, type
, f
))
1868 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1869 && require_type (dtp
, BT_INTEGER
, type
, f
))
1871 write_b (dtp
, f
, p
, kind
);
1877 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1878 && require_numeric_type (dtp
, type
, f
))
1880 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1881 && require_type (dtp
, BT_INTEGER
, type
, f
))
1883 write_o (dtp
, f
, p
, kind
);
1889 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1890 && require_numeric_type (dtp
, type
, f
))
1892 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1893 && require_type (dtp
, BT_INTEGER
, type
, f
))
1895 write_z (dtp
, f
, p
, kind
);
1902 /* It is possible to have FMT_A with something not BT_CHARACTER such
1903 as when writing out hollerith strings, so check both type
1904 and kind before calling wide character routines. */
1905 if (type
== BT_CHARACTER
&& kind
== 4)
1906 write_a_char4 (dtp
, f
, p
, size
);
1908 write_a (dtp
, f
, p
, size
);
1914 write_l (dtp
, f
, p
, kind
);
1920 if (require_type (dtp
, BT_REAL
, type
, f
))
1922 write_d (dtp
, f
, p
, kind
);
1928 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1930 char tmp_iomsg
[IOMSG_LEN
] = "";
1932 gfc_charlen_type child_iomsg_len
;
1934 int *child_iostat
= NULL
;
1936 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1938 /* Build the iotype string. */
1939 if (iotype_len
== 0)
1945 iotype
= get_dt_format (f
->u
.udf
.string
, &iotype_len
);
1947 /* Set iostat, intent(out). */
1949 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1950 dtp
->common
.iostat
: &noiostat
;
1952 /* Set iomsg, intent(inout). */
1953 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1955 child_iomsg
= dtp
->common
.iomsg
;
1956 child_iomsg_len
= dtp
->common
.iomsg_len
;
1960 child_iomsg
= tmp_iomsg
;
1961 child_iomsg_len
= IOMSG_LEN
;
1964 if (check_dtio_proc (dtp
, f
))
1967 /* Call the user defined formatted WRITE procedure. */
1968 dtp
->u
.p
.current_unit
->child_dtio
++;
1970 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1971 child_iostat
, child_iomsg
,
1972 iotype_len
, child_iomsg_len
);
1973 dtp
->u
.p
.current_unit
->child_dtio
--;
1975 if (f
->u
.udf
.string_len
!= 0)
1977 /* Note: vlist is freed in free_format_data. */
1983 if (require_type (dtp
, BT_REAL
, type
, f
))
1985 write_e (dtp
, f
, p
, kind
);
1991 if (require_type (dtp
, BT_REAL
, type
, f
))
1993 write_en (dtp
, f
, p
, kind
);
1999 if (require_type (dtp
, BT_REAL
, type
, f
))
2001 write_es (dtp
, f
, p
, kind
);
2007 if (require_type (dtp
, BT_REAL
, type
, f
))
2009 write_f (dtp
, f
, p
, kind
);
2018 write_i (dtp
, f
, p
, kind
);
2021 write_l (dtp
, f
, p
, kind
);
2025 write_a_char4 (dtp
, f
, p
, size
);
2027 write_a (dtp
, f
, p
, size
);
2030 if (f
->u
.real
.w
== 0)
2031 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
2033 write_d (dtp
, f
, p
, kind
);
2036 internal_error (&dtp
->common
,
2037 "formatted_transfer(): Bad type");
2042 consume_data_flag
= 0;
2043 write_constant_string (dtp
, f
);
2046 /* Format codes that don't transfer data. */
2049 consume_data_flag
= 0;
2051 dtp
->u
.p
.skips
+= f
->u
.n
;
2052 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
2053 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
2054 /* Writes occur just before the switch on f->format, above, so
2055 that trailing blanks are suppressed, unless we are doing a
2056 non-advancing write in which case we want to output the blanks
2058 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2060 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
2061 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2067 consume_data_flag
= 0;
2069 if (f
->format
== FMT_TL
)
2072 /* Handle the special case when no bytes have been used yet.
2073 Cannot go below zero. */
2074 if (bytes_used
== 0)
2076 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
2077 dtp
->u
.p
.skips
-= f
->u
.n
;
2078 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
2081 pos
= bytes_used
- f
->u
.n
;
2084 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
2086 /* Standard 10.6.1.1: excessive left tabbing is reset to the
2087 left tab limit. We do not check if the position has gone
2088 beyond the end of record because a subsequent tab could
2089 bring us back again. */
2090 pos
= pos
< 0 ? 0 : pos
;
2092 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
2093 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
2094 + pos
- dtp
->u
.p
.max_pos
;
2095 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
2096 ? 0 : dtp
->u
.p
.pending_spaces
;
2100 consume_data_flag
= 0;
2101 dtp
->u
.p
.sign_status
= SIGN_S
;
2105 consume_data_flag
= 0;
2106 dtp
->u
.p
.sign_status
= SIGN_SS
;
2110 consume_data_flag
= 0;
2111 dtp
->u
.p
.sign_status
= SIGN_SP
;
2115 consume_data_flag
= 0 ;
2116 dtp
->u
.p
.blank_status
= BLANK_NULL
;
2120 consume_data_flag
= 0;
2121 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
2125 consume_data_flag
= 0;
2126 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
2130 consume_data_flag
= 0;
2131 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
2135 consume_data_flag
= 0;
2136 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
2140 consume_data_flag
= 0;
2141 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
2145 consume_data_flag
= 0;
2146 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
2150 consume_data_flag
= 0;
2151 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
2155 consume_data_flag
= 0;
2156 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
2160 consume_data_flag
= 0;
2161 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
2165 consume_data_flag
= 0;
2166 dtp
->u
.p
.scale_factor
= f
->u
.k
;
2170 consume_data_flag
= 0;
2171 dtp
->u
.p
.seen_dollar
= 1;
2175 consume_data_flag
= 0;
2176 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2177 next_record (dtp
, 0);
2181 /* A colon descriptor causes us to exit this loop (in
2182 particular preventing another / descriptor from being
2183 processed) unless there is another data item to be
2185 consume_data_flag
= 0;
2191 internal_error (&dtp
->common
, "Bad format node");
2194 /* Adjust the item count and data pointer. */
2196 if ((consume_data_flag
> 0) && (n
> 0))
2199 p
= ((char *) p
) + size
;
2202 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
2203 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
2208 /* Come here when we need a data descriptor but don't have one. We
2209 push the current format node back onto the input, then return and
2210 let the user program call us back with the data. */
2212 unget_format (dtp
, f
);
2215 /* This function is first called from data_init_transfer to initiate the loop
2216 over each item in the format, transferring data as required. Subsequent
2217 calls to this function occur for each data item foound in the READ/WRITE
2218 statement. The item_count is incremented for each call. Since the first
2219 call is from data_transfer_init, the item_count is always one greater than
2220 the actual count number of the item being transferred. */
2223 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2224 size_t size
, size_t nelems
)
2230 size_t stride
= type
== BT_CHARACTER
?
2231 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2232 if (dtp
->u
.p
.mode
== READING
)
2234 /* Big loop over all the elements. */
2235 for (elem
= 0; elem
< nelems
; elem
++)
2237 dtp
->u
.p
.item_count
++;
2238 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2243 /* Big loop over all the elements. */
2244 for (elem
= 0; elem
< nelems
; elem
++)
2246 dtp
->u
.p
.item_count
++;
2247 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2253 /* Data transfer entry points. The type of the data entity is
2254 implicit in the subroutine call. This prevents us from having to
2255 share a common enum with the compiler. */
2258 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
2260 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2262 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
2266 transfer_integer_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2268 transfer_integer (dtp
, p
, kind
);
2272 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
2275 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2277 size
= size_from_real_kind (kind
);
2278 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
2282 transfer_real_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2284 transfer_real (dtp
, p
, kind
);
2288 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
2290 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2292 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
2296 transfer_logical_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2298 transfer_logical (dtp
, p
, kind
);
2302 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
2304 static char *empty_string
[0];
2306 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2309 /* Strings of zero length can have p == NULL, which confuses the
2310 transfer routines into thinking we need more data elements. To avoid
2311 this, we give them a nice pointer. */
2312 if (len
== 0 && p
== NULL
)
2315 /* Set kind here to 1. */
2316 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
2320 transfer_character_write (st_parameter_dt
*dtp
, void *p
, int len
)
2322 transfer_character (dtp
, p
, len
);
2326 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2328 static char *empty_string
[0];
2330 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2333 /* Strings of zero length can have p == NULL, which confuses the
2334 transfer routines into thinking we need more data elements. To avoid
2335 this, we give them a nice pointer. */
2336 if (len
== 0 && p
== NULL
)
2339 /* Here we pass the actual kind value. */
2340 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
2344 transfer_character_wide_write (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2346 transfer_character_wide (dtp
, p
, len
, kind
);
2350 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
2353 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2355 size
= size_from_complex_kind (kind
);
2356 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
2360 transfer_complex_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2362 transfer_complex (dtp
, p
, kind
);
2366 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2367 gfc_charlen_type charlen
)
2369 index_type count
[GFC_MAX_DIMENSIONS
];
2370 index_type extent
[GFC_MAX_DIMENSIONS
];
2371 index_type stride
[GFC_MAX_DIMENSIONS
];
2372 index_type stride0
, rank
, size
, n
;
2377 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2380 iotype
= (bt
) GFC_DESCRIPTOR_TYPE (desc
);
2381 size
= iotype
== BT_CHARACTER
? charlen
: GFC_DESCRIPTOR_SIZE (desc
);
2383 rank
= GFC_DESCRIPTOR_RANK (desc
);
2384 for (n
= 0; n
< rank
; n
++)
2387 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
2388 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
2390 /* If the extent of even one dimension is zero, then the entire
2391 array section contains zero elements, so we return after writing
2392 a zero array record. */
2397 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2402 stride0
= stride
[0];
2404 /* If the innermost dimension has a stride of 1, we can do the transfer
2405 in contiguous chunks. */
2406 if (stride0
== size
)
2411 data
= GFC_DESCRIPTOR_DATA (desc
);
2415 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2416 data
+= stride0
* tsize
;
2419 while (count
[n
] == extent
[n
])
2422 data
-= stride
[n
] * extent
[n
];
2439 transfer_array_write (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2440 gfc_charlen_type charlen
)
2442 transfer_array (dtp
, desc
, kind
, charlen
);
2446 /* User defined input/output iomsg. */
2448 #define IOMSG_LEN 256
2451 transfer_derived (st_parameter_dt
*parent
, void *dtio_source
, void *dtio_proc
)
2453 if (parent
->u
.p
.current_unit
)
2455 if (parent
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2456 parent
->u
.p
.ufdtio_ptr
= (unformatted_dtio
) dtio_proc
;
2458 parent
->u
.p
.fdtio_ptr
= (formatted_dtio
) dtio_proc
;
2460 parent
->u
.p
.transfer (parent
, BT_CLASS
, dtio_source
, 0, 0, 1);
2464 /* Preposition a sequential unformatted file while reading. */
2467 us_read (st_parameter_dt
*dtp
, int continued
)
2474 if (compile_options
.record_marker
== 0)
2475 n
= sizeof (GFC_INTEGER_4
);
2477 n
= compile_options
.record_marker
;
2479 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
2480 if (unlikely (nr
< 0))
2482 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2488 return; /* end of file */
2490 else if (unlikely (n
!= nr
))
2492 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2496 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2497 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2501 case sizeof(GFC_INTEGER_4
):
2502 memcpy (&i4
, &i
, sizeof (i4
));
2506 case sizeof(GFC_INTEGER_8
):
2507 memcpy (&i8
, &i
, sizeof (i8
));
2512 runtime_error ("Illegal value for record marker");
2522 case sizeof(GFC_INTEGER_4
):
2523 memcpy (&u32
, &i
, sizeof (u32
));
2524 u32
= __builtin_bswap32 (u32
);
2525 memcpy (&i4
, &u32
, sizeof (i4
));
2529 case sizeof(GFC_INTEGER_8
):
2530 memcpy (&u64
, &i
, sizeof (u64
));
2531 u64
= __builtin_bswap64 (u64
);
2532 memcpy (&i8
, &u64
, sizeof (i8
));
2537 runtime_error ("Illegal value for record marker");
2544 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
2545 dtp
->u
.p
.current_unit
->continued
= 0;
2549 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
2550 dtp
->u
.p
.current_unit
->continued
= 1;
2554 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2558 /* Preposition a sequential unformatted file while writing. This
2559 amount to writing a bogus length that will be filled in later. */
2562 us_write (st_parameter_dt
*dtp
, int continued
)
2569 if (compile_options
.record_marker
== 0)
2570 nbytes
= sizeof (GFC_INTEGER_4
);
2572 nbytes
= compile_options
.record_marker
;
2574 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2575 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2577 /* For sequential unformatted, if RECL= was not specified in the OPEN
2578 we write until we have more bytes than can fit in the subrecord
2579 markers, then we write a new subrecord. */
2581 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2582 dtp
->u
.p
.current_unit
->recl_subrecord
;
2583 dtp
->u
.p
.current_unit
->continued
= continued
;
2587 /* Position to the next record prior to transfer. We are assumed to
2588 be before the next record. We also calculate the bytes in the next
2592 pre_position (st_parameter_dt
*dtp
)
2594 if (dtp
->u
.p
.current_unit
->current_record
)
2595 return; /* Already positioned. */
2597 switch (current_mode (dtp
))
2599 case FORMATTED_STREAM
:
2600 case UNFORMATTED_STREAM
:
2601 /* There are no records with stream I/O. If the position was specified
2602 data_transfer_init has already positioned the file. If no position
2603 was specified, we continue from where we last left off. I.e.
2604 there is nothing to do here. */
2607 case UNFORMATTED_SEQUENTIAL
:
2608 if (dtp
->u
.p
.mode
== READING
)
2615 case FORMATTED_SEQUENTIAL
:
2616 case FORMATTED_DIRECT
:
2617 case UNFORMATTED_DIRECT
:
2618 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2622 dtp
->u
.p
.current_unit
->current_record
= 1;
2626 /* Initialize things for a data transfer. This code is common for
2627 both reading and writing. */
2630 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2632 unit_flags u_flags
; /* Used for creating a unit if needed. */
2633 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2634 namelist_info
*ionml
;
2636 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2638 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2640 dtp
->u
.p
.ionml
= ionml
;
2641 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2643 dtp
->u
.p
.cc
.len
= 0;
2645 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2648 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2650 if (dtp
->u
.p
.current_unit
== NULL
)
2652 /* This means we tried to access an external unit < 0 without
2653 having opened it first with NEWUNIT=. */
2654 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2655 "Unit number is negative and unit was not already "
2656 "opened with OPEN(NEWUNIT=...)");
2659 else if (dtp
->u
.p
.current_unit
->s
== NULL
)
2660 { /* Open the unit with some default flags. */
2661 st_parameter_open opp
;
2664 memset (&u_flags
, '\0', sizeof (u_flags
));
2665 u_flags
.access
= ACCESS_SEQUENTIAL
;
2666 u_flags
.action
= ACTION_READWRITE
;
2668 /* Is it unformatted? */
2669 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2670 | IOPARM_DT_IONML_SET
)))
2671 u_flags
.form
= FORM_UNFORMATTED
;
2673 u_flags
.form
= FORM_UNSPECIFIED
;
2675 u_flags
.delim
= DELIM_UNSPECIFIED
;
2676 u_flags
.blank
= BLANK_UNSPECIFIED
;
2677 u_flags
.pad
= PAD_UNSPECIFIED
;
2678 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2679 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2680 u_flags
.async
= ASYNC_UNSPECIFIED
;
2681 u_flags
.round
= ROUND_UNSPECIFIED
;
2682 u_flags
.sign
= SIGN_UNSPECIFIED
;
2683 u_flags
.share
= SHARE_UNSPECIFIED
;
2684 u_flags
.cc
= CC_UNSPECIFIED
;
2685 u_flags
.readonly
= 0;
2687 u_flags
.status
= STATUS_UNKNOWN
;
2689 conv
= get_unformatted_convert (dtp
->common
.unit
);
2691 if (conv
== GFC_CONVERT_NONE
)
2692 conv
= compile_options
.convert
;
2694 /* We use big_endian, which is 0 on little-endian machines
2695 and 1 on big-endian machines. */
2698 case GFC_CONVERT_NATIVE
:
2699 case GFC_CONVERT_SWAP
:
2702 case GFC_CONVERT_BIG
:
2703 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2706 case GFC_CONVERT_LITTLE
:
2707 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2711 internal_error (&opp
.common
, "Illegal value for CONVERT");
2715 u_flags
.convert
= conv
;
2717 opp
.common
= dtp
->common
;
2718 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2719 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2720 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2721 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2722 if (dtp
->u
.p
.current_unit
== NULL
)
2726 if (dtp
->u
.p
.current_unit
->child_dtio
== 0)
2728 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2730 dtp
->u
.p
.current_unit
->has_size
= true;
2731 /* Initialize the count. */
2732 dtp
->u
.p
.current_unit
->size_used
= 0;
2735 dtp
->u
.p
.current_unit
->has_size
= false;
2738 /* Check the action. */
2740 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2742 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2743 "Cannot read from file opened for WRITE");
2747 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2749 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2750 "Cannot write to file opened for READ");
2754 dtp
->u
.p
.first_item
= 1;
2756 /* Check the format. */
2758 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2761 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2762 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2765 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2766 "Format present for UNFORMATTED data transfer");
2770 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2772 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2774 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2775 "A format cannot be specified with a namelist");
2779 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2780 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2782 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2783 "Missing format for FORMATTED data transfer");
2787 if (is_internal_unit (dtp
)
2788 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2790 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2791 "Internal file cannot be accessed by UNFORMATTED "
2796 /* Check the record or position number. */
2798 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2799 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2801 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2802 "Direct access data transfer requires record number");
2806 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2808 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2810 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2811 "Record number not allowed for sequential access "
2816 if (compile_options
.warn_std
&&
2817 dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
)
2819 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2820 "Sequential READ or WRITE not allowed after "
2821 "EOF marker, possibly use REWIND or BACKSPACE");
2825 /* Process the ADVANCE option. */
2827 dtp
->u
.p
.advance_status
2828 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2829 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2830 "Bad ADVANCE parameter in data transfer statement");
2832 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2834 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2836 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2837 "ADVANCE specification conflicts with sequential "
2842 if (is_internal_unit (dtp
))
2844 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2845 "ADVANCE specification conflicts with internal file");
2849 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2850 != IOPARM_DT_HAS_FORMAT
)
2852 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2853 "ADVANCE specification requires an explicit format");
2860 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2862 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2864 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2865 "EOR specification requires an ADVANCE specification "
2870 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2871 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2873 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2874 "SIZE specification requires an ADVANCE "
2875 "specification of NO");
2880 { /* Write constraints. */
2881 if ((cf
& IOPARM_END
) != 0)
2883 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2884 "END specification cannot appear in a write "
2889 if ((cf
& IOPARM_EOR
) != 0)
2891 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2892 "EOR specification cannot appear in a write "
2897 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2899 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2900 "SIZE specification cannot appear in a write "
2906 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2907 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2909 /* Check the decimal mode. */
2910 dtp
->u
.p
.current_unit
->decimal_status
2911 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2912 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2913 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2916 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2917 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2919 /* Check the round mode. */
2920 dtp
->u
.p
.current_unit
->round_status
2921 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
2922 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
2923 round_opt
, "Bad ROUND parameter in data transfer "
2926 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
2927 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
2929 /* Check the sign mode. */
2930 dtp
->u
.p
.sign_status
2931 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2932 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2933 "Bad SIGN parameter in data transfer statement");
2935 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2936 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2938 /* Check the blank mode. */
2939 dtp
->u
.p
.blank_status
2940 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2941 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2943 "Bad BLANK parameter in data transfer statement");
2945 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2946 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2948 /* Check the delim mode. */
2949 dtp
->u
.p
.current_unit
->delim_status
2950 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2951 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2952 delim_opt
, "Bad DELIM parameter in data transfer statement");
2954 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2956 if (ionml
&& dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_UNSPECIFIED
)
2957 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
2959 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2962 /* Check the pad mode. */
2963 dtp
->u
.p
.current_unit
->pad_status
2964 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2965 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2966 "Bad PAD parameter in data transfer statement");
2968 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2969 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2971 /* Check to see if we might be reading what we wrote before */
2973 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2974 && !is_internal_unit (dtp
))
2976 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2978 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2979 sflush(dtp
->u
.p
.current_unit
->s
);
2982 /* Check the POS= specifier: that it is in range and that it is used with a
2983 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2985 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2987 if (is_stream_io (dtp
))
2992 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2993 "POS=specifier must be positive");
2997 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2999 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3000 "POS=specifier too large");
3004 dtp
->rec
= dtp
->pos
;
3006 if (dtp
->u
.p
.mode
== READING
)
3008 /* Reset the endfile flag; if we hit EOF during reading
3009 we'll set the flag and generate an error at that point
3010 rather than worrying about it here. */
3011 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
3014 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
3016 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3017 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
3019 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3022 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
3027 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3028 "POS=specifier not allowed, "
3029 "Try OPEN with ACCESS='stream'");
3035 /* Sanity checks on the record number. */
3036 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
3040 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3041 "Record number must be positive");
3045 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
3047 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3048 "Record number too large");
3052 /* Make sure format buffer is reset. */
3053 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3054 fbuf_reset (dtp
->u
.p
.current_unit
);
3057 /* Check whether the record exists to be read. Only
3058 a partial record needs to exist. */
3060 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
3061 * dtp
->u
.p
.current_unit
->recl
>= ssize (dtp
->u
.p
.current_unit
->s
))
3063 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3064 "Non-existing record number");
3068 /* Position the file. */
3069 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
3070 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
3072 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3076 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
3078 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3079 "Record number not allowed for stream access "
3085 /* Bugware for badly written mixed C-Fortran I/O. */
3086 if (!is_internal_unit (dtp
))
3087 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
3089 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
3091 /* Set the maximum position reached from the previous I/O operation. This
3092 could be greater than zero from a previous non-advancing write. */
3093 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
3098 /* Set up the subroutine that will handle the transfers. */
3102 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3103 dtp
->u
.p
.transfer
= unformatted_read
;
3106 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3108 if (dtp
->u
.p
.current_unit
->child_dtio
== 0)
3109 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
3110 dtp
->u
.p
.transfer
= list_formatted_read
;
3113 dtp
->u
.p
.transfer
= formatted_transfer
;
3118 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3119 dtp
->u
.p
.transfer
= unformatted_write
;
3122 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3123 dtp
->u
.p
.transfer
= list_formatted_write
;
3125 dtp
->u
.p
.transfer
= formatted_transfer
;
3129 /* Make sure that we don't do a read after a nonadvancing write. */
3133 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
3135 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3136 "Cannot READ after a nonadvancing WRITE");
3142 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
3143 dtp
->u
.p
.current_unit
->read_bad
= 1;
3146 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3148 #ifdef HAVE_USELOCALE
3149 dtp
->u
.p
.old_locale
= uselocale (c_locale
);
3151 __gthread_mutex_lock (&old_locale_lock
);
3152 if (!old_locale_ctr
++)
3154 old_locale
= setlocale (LC_NUMERIC
, NULL
);
3155 setlocale (LC_NUMERIC
, "C");
3157 __gthread_mutex_unlock (&old_locale_lock
);
3159 /* Start the data transfer if we are doing a formatted transfer. */
3160 if ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0
3161 && dtp
->u
.p
.ionml
== NULL
)
3162 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
3167 /* Initialize an array_loop_spec given the array descriptor. The function
3168 returns the index of the last element of the array, and also returns
3169 starting record, where the first I/O goes to (necessary in case of
3170 negative strides). */
3173 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
3174 gfc_offset
*start_record
)
3176 int rank
= GFC_DESCRIPTOR_RANK(desc
);
3185 for (i
=0; i
<rank
; i
++)
3187 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3188 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3189 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
3190 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
3191 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
3192 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
3194 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
3196 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3197 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3201 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3202 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3203 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3204 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3214 /* Determine the index to the next record in an internal unit array by
3215 by incrementing through the array_loop_spec. */
3218 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
3226 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
3231 if (ls
[i
].idx
> ls
[i
].end
)
3233 ls
[i
].idx
= ls
[i
].start
;
3239 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
3249 /* Skip to the end of the current record, taking care of an optional
3250 record marker of size bytes. If the file is not seekable, we
3251 read chunks of size MAX_READ until we get to the right
3255 skip_record (st_parameter_dt
*dtp
, ssize_t bytes
)
3257 ssize_t rlength
, readb
;
3258 #define MAX_READ 4096
3261 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
3262 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
3265 /* Direct access files do not generate END conditions,
3267 if (sseek (dtp
->u
.p
.current_unit
->s
,
3268 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
3270 /* Seeking failed, fall back to seeking by reading data. */
3271 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
3274 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
3275 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3277 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
3280 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3284 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
3288 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= 0;
3292 /* Advance to the next record reading unformatted files, taking
3293 care of subrecords. If complete_record is nonzero, we loop
3294 until all subrecords are cleared. */
3297 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
3301 bytes
= compile_options
.record_marker
== 0 ?
3302 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
3307 /* Skip over tail */
3309 skip_record (dtp
, bytes
);
3311 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
3320 min_off (gfc_offset a
, gfc_offset b
)
3322 return (a
< b
? a
: b
);
3326 /* Space to the next record for read mode. */
3329 next_record_r (st_parameter_dt
*dtp
, int done
)
3336 switch (current_mode (dtp
))
3338 /* No records in unformatted STREAM I/O. */
3339 case UNFORMATTED_STREAM
:
3342 case UNFORMATTED_SEQUENTIAL
:
3343 next_record_r_unf (dtp
, 1);
3344 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3347 case FORMATTED_DIRECT
:
3348 case UNFORMATTED_DIRECT
:
3349 skip_record (dtp
, dtp
->u
.p
.current_unit
->bytes_left
);
3352 case FORMATTED_STREAM
:
3353 case FORMATTED_SEQUENTIAL
:
3354 /* read_sf has already terminated input because of an '\n', or
3356 if (dtp
->u
.p
.sf_seen_eor
)
3358 dtp
->u
.p
.sf_seen_eor
= 0;
3362 if (is_internal_unit (dtp
))
3364 if (is_array_io (dtp
))
3368 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3370 if (!done
&& finished
)
3373 /* Now seek to this record. */
3374 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3375 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3377 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3380 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3384 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3385 bytes_left
= min_off (bytes_left
,
3386 ssize (dtp
->u
.p
.current_unit
->s
)
3387 - stell (dtp
->u
.p
.current_unit
->s
));
3388 if (sseek (dtp
->u
.p
.current_unit
->s
,
3389 bytes_left
, SEEK_CUR
) < 0)
3391 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3394 dtp
->u
.p
.current_unit
->bytes_left
3395 = dtp
->u
.p
.current_unit
->recl
;
3399 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
3404 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
3408 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3411 if (is_stream_io (dtp
)
3412 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
3413 || dtp
->u
.p
.current_unit
->bytes_left
3414 == dtp
->u
.p
.current_unit
->recl
)
3420 if (is_stream_io (dtp
))
3421 dtp
->u
.p
.current_unit
->strm_pos
++;
3432 /* Small utility function to write a record marker, taking care of
3433 byte swapping and of choosing the correct size. */
3436 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
3442 if (compile_options
.record_marker
== 0)
3443 len
= sizeof (GFC_INTEGER_4
);
3445 len
= compile_options
.record_marker
;
3447 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
3448 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
3452 case sizeof (GFC_INTEGER_4
):
3454 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
3457 case sizeof (GFC_INTEGER_8
):
3459 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
3463 runtime_error ("Illegal value for record marker");
3473 case sizeof (GFC_INTEGER_4
):
3475 memcpy (&u32
, &buf4
, sizeof (u32
));
3476 u32
= __builtin_bswap32 (u32
);
3477 return swrite (dtp
->u
.p
.current_unit
->s
, &u32
, len
);
3480 case sizeof (GFC_INTEGER_8
):
3482 memcpy (&u64
, &buf8
, sizeof (u64
));
3483 u64
= __builtin_bswap64 (u64
);
3484 return swrite (dtp
->u
.p
.current_unit
->s
, &u64
, len
);
3488 runtime_error ("Illegal value for record marker");
3495 /* Position to the next (sub)record in write mode for
3496 unformatted sequential files. */
3499 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
3501 gfc_offset m
, m_write
, record_marker
;
3503 /* Bytes written. */
3504 m
= dtp
->u
.p
.current_unit
->recl_subrecord
3505 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3507 if (compile_options
.record_marker
== 0)
3508 record_marker
= sizeof (GFC_INTEGER_4
);
3510 record_marker
= compile_options
.record_marker
;
3512 /* Seek to the head and overwrite the bogus length with the real
3515 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- record_marker
,
3524 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3527 /* Seek past the end of the current record. */
3529 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
, SEEK_CUR
) < 0))
3532 /* Write the length tail. If we finish a record containing
3533 subrecords, we write out the negative length. */
3535 if (dtp
->u
.p
.current_unit
->continued
)
3540 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3546 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3552 /* Utility function like memset() but operating on streams. Return
3553 value is same as for POSIX write(). */
3556 sset (stream
* s
, int c
, ssize_t nbyte
)
3558 #define WRITE_CHUNK 256
3559 char p
[WRITE_CHUNK
];
3560 ssize_t bytes_left
, trans
;
3562 if (nbyte
< WRITE_CHUNK
)
3563 memset (p
, c
, nbyte
);
3565 memset (p
, c
, WRITE_CHUNK
);
3568 while (bytes_left
> 0)
3570 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
3571 trans
= swrite (s
, p
, trans
);
3574 bytes_left
-= trans
;
3577 return nbyte
- bytes_left
;
3581 /* Finish up a record according to the legacy carriagecontrol type, based
3582 on the first character in the record. */
3585 next_record_cc (st_parameter_dt
*dtp
)
3587 /* Only valid with CARRIAGECONTROL=FORTRAN. */
3588 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
3591 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3592 if (dtp
->u
.p
.cc
.len
> 0)
3594 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, dtp
->u
.p
.cc
.len
);
3596 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3598 /* Output CR for the first character with default CC setting. */
3599 *(p
++) = dtp
->u
.p
.cc
.u
.end
;
3600 if (dtp
->u
.p
.cc
.len
> 1)
3601 *p
= dtp
->u
.p
.cc
.u
.end
;
3605 /* Position to the next record in write mode. */
3608 next_record_w (st_parameter_dt
*dtp
, int done
)
3610 gfc_offset m
, record
, max_pos
;
3613 /* Zero counters for X- and T-editing. */
3614 max_pos
= dtp
->u
.p
.max_pos
;
3615 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
3617 switch (current_mode (dtp
))
3619 /* No records in unformatted STREAM I/O. */
3620 case UNFORMATTED_STREAM
:
3623 case FORMATTED_DIRECT
:
3624 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
3627 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3628 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
3629 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
3630 dtp
->u
.p
.current_unit
->bytes_left
)
3631 != dtp
->u
.p
.current_unit
->bytes_left
)
3636 case UNFORMATTED_DIRECT
:
3637 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
3639 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3640 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3645 case UNFORMATTED_SEQUENTIAL
:
3646 next_record_w_unf (dtp
, 0);
3647 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3650 case FORMATTED_STREAM
:
3651 case FORMATTED_SEQUENTIAL
:
3653 if (is_internal_unit (dtp
))
3656 if (is_array_io (dtp
))
3660 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3662 /* If the farthest position reached is greater than current
3663 position, adjust the position and set length to pad out
3664 whats left. Otherwise just pad whats left.
3665 (for character array unit) */
3666 m
= dtp
->u
.p
.current_unit
->recl
3667 - dtp
->u
.p
.current_unit
->bytes_left
;
3670 length
= (int) (max_pos
- m
);
3671 if (sseek (dtp
->u
.p
.current_unit
->s
,
3672 length
, SEEK_CUR
) < 0)
3674 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3677 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3680 p
= write_block (dtp
, length
);
3684 if (unlikely (is_char4_unit (dtp
)))
3686 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3687 memset4 (p4
, ' ', length
);
3690 memset (p
, ' ', length
);
3692 /* Now that the current record has been padded out,
3693 determine where the next record in the array is. */
3694 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3697 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3699 /* Now seek to this record */
3700 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3702 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3704 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3708 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3714 /* If this is the last call to next_record move to the farthest
3715 position reached and set length to pad out the remainder
3716 of the record. (for character scaler unit) */
3719 m
= dtp
->u
.p
.current_unit
->recl
3720 - dtp
->u
.p
.current_unit
->bytes_left
;
3723 length
= (int) (max_pos
- m
);
3724 if (sseek (dtp
->u
.p
.current_unit
->s
,
3725 length
, SEEK_CUR
) < 0)
3727 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3730 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3733 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3737 p
= write_block (dtp
, length
);
3741 if (unlikely (is_char4_unit (dtp
)))
3743 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3744 memset4 (p4
, (gfc_char4_t
) ' ', length
);
3747 memset (p
, ' ', length
);
3751 /* Handle legacy CARRIAGECONTROL line endings. */
3752 else if (dtp
->u
.p
.current_unit
->flags
.cc
== CC_FORTRAN
)
3753 next_record_cc (dtp
);
3756 /* Skip newlines for CC=CC_NONE. */
3757 const int len
= (dtp
->u
.p
.current_unit
->flags
.cc
== CC_NONE
)
3764 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3765 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
3767 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3775 if (is_stream_io (dtp
))
3777 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3778 if (dtp
->u
.p
.current_unit
->strm_pos
3779 < ssize (dtp
->u
.p
.current_unit
->s
))
3780 unit_truncate (dtp
->u
.p
.current_unit
,
3781 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3789 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3794 /* Position to the next record, which means moving to the end of the
3795 current record. This can happen under several different
3796 conditions. If the done flag is not set, we get ready to process
3800 next_record (st_parameter_dt
*dtp
, int done
)
3802 gfc_offset fp
; /* File position. */
3804 dtp
->u
.p
.current_unit
->read_bad
= 0;
3806 if (dtp
->u
.p
.mode
== READING
)
3807 next_record_r (dtp
, done
);
3809 next_record_w (dtp
, done
);
3811 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3813 if (!is_stream_io (dtp
))
3815 /* Since we have changed the position, set it to unspecified so
3816 that INQUIRE(POSITION=) knows it needs to look into it. */
3818 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_UNSPECIFIED
;
3820 dtp
->u
.p
.current_unit
->current_record
= 0;
3821 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3823 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3824 /* Calculate next record, rounding up partial records. */
3825 dtp
->u
.p
.current_unit
->last_record
=
3826 (fp
+ dtp
->u
.p
.current_unit
->recl
) /
3827 dtp
->u
.p
.current_unit
->recl
- 1;
3830 dtp
->u
.p
.current_unit
->last_record
++;
3836 smarkeor (dtp
->u
.p
.current_unit
->s
);
3840 /* Finalize the current data transfer. For a nonadvancing transfer,
3841 this means advancing to the next record. For internal units close the
3842 stream associated with the unit. */
3845 finalize_transfer (st_parameter_dt
*dtp
)
3847 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3849 if ((dtp
->u
.p
.ionml
!= NULL
)
3850 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3852 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3853 namelist_read (dtp
);
3855 namelist_write (dtp
);
3858 if (dtp
->u
.p
.current_unit
&& (dtp
->u
.p
.current_unit
->child_dtio
> 0))
3860 if (cf
& IOPARM_DT_HAS_FORMAT
)
3862 free (dtp
->u
.p
.fmt
);
3868 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3869 *dtp
->size
= dtp
->u
.p
.current_unit
->size_used
;
3871 if (dtp
->u
.p
.eor_condition
)
3873 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3877 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3879 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3880 dtp
->u
.p
.current_unit
->current_record
= 0;
3884 dtp
->u
.p
.transfer
= NULL
;
3885 if (dtp
->u
.p
.current_unit
== NULL
)
3888 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3890 finish_list_read (dtp
);
3894 if (dtp
->u
.p
.mode
== WRITING
)
3895 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3896 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3898 if (is_stream_io (dtp
))
3900 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3901 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3902 next_record (dtp
, 1);
3907 dtp
->u
.p
.current_unit
->current_record
= 0;
3909 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3911 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3912 dtp
->u
.p
.seen_dollar
= 0;
3916 /* For non-advancing I/O, save the current maximum position for use in the
3917 next I/O operation if needed. */
3918 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3920 if (dtp
->u
.p
.skips
> 0)
3923 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
3924 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
3925 - dtp
->u
.p
.current_unit
->bytes_left
);
3927 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
3930 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3931 - dtp
->u
.p
.current_unit
->bytes_left
);
3932 dtp
->u
.p
.current_unit
->saved_pos
=
3933 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3934 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3937 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3938 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3939 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3941 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3943 next_record (dtp
, 1);
3946 #ifdef HAVE_USELOCALE
3947 if (dtp
->u
.p
.old_locale
!= (locale_t
) 0)
3949 uselocale (dtp
->u
.p
.old_locale
);
3950 dtp
->u
.p
.old_locale
= (locale_t
) 0;
3953 __gthread_mutex_lock (&old_locale_lock
);
3954 if (!--old_locale_ctr
)
3956 setlocale (LC_NUMERIC
, old_locale
);
3959 __gthread_mutex_unlock (&old_locale_lock
);
3963 /* Transfer function for IOLENGTH. It doesn't actually do any
3964 data transfer, it just updates the length counter. */
3967 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3968 void *dest
__attribute__ ((unused
)),
3969 int kind
__attribute__((unused
)),
3970 size_t size
, size_t nelems
)
3972 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3973 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3977 /* Initialize the IOLENGTH data transfer. This function is in essence
3978 a very much simplified version of data_transfer_init(), because it
3979 doesn't have to deal with units at all. */
3982 iolength_transfer_init (st_parameter_dt
*dtp
)
3984 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3987 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3989 /* Set up the subroutine that will handle the transfers. */
3991 dtp
->u
.p
.transfer
= iolength_transfer
;
3995 /* Library entry point for the IOLENGTH form of the INQUIRE
3996 statement. The IOLENGTH form requires no I/O to be performed, but
3997 it must still be a runtime library call so that we can determine
3998 the iolength for dynamic arrays and such. */
4000 extern void st_iolength (st_parameter_dt
*);
4001 export_proto(st_iolength
);
4004 st_iolength (st_parameter_dt
*dtp
)
4006 library_start (&dtp
->common
);
4007 iolength_transfer_init (dtp
);
4010 extern void st_iolength_done (st_parameter_dt
*);
4011 export_proto(st_iolength_done
);
4014 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
4021 /* The READ statement. */
4023 extern void st_read (st_parameter_dt
*);
4024 export_proto(st_read
);
4027 st_read (st_parameter_dt
*dtp
)
4029 library_start (&dtp
->common
);
4031 data_transfer_init (dtp
, 1);
4034 extern void st_read_done (st_parameter_dt
*);
4035 export_proto(st_read_done
);
4038 st_read_done (st_parameter_dt
*dtp
)
4040 finalize_transfer (dtp
);
4044 /* If this is a parent READ statement we do not need to retain the
4045 internal unit structure for child use. Free it and stash the unit
4046 number for reuse. */
4047 if (dtp
->u
.p
.current_unit
!= NULL
4048 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4050 if (is_internal_unit (dtp
) &&
4051 (dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4053 free (dtp
->u
.p
.current_unit
->filename
);
4054 dtp
->u
.p
.current_unit
->filename
= NULL
;
4055 free (dtp
->u
.p
.current_unit
->s
);
4056 dtp
->u
.p
.current_unit
->s
= NULL
;
4057 if (dtp
->u
.p
.current_unit
->ls
)
4058 free (dtp
->u
.p
.current_unit
->ls
);
4059 dtp
->u
.p
.current_unit
->ls
= NULL
;
4060 stash_internal_unit (dtp
);
4062 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
4064 free_format_data (dtp
->u
.p
.fmt
);
4067 unlock_unit (dtp
->u
.p
.current_unit
);
4073 extern void st_write (st_parameter_dt
*);
4074 export_proto(st_write
);
4077 st_write (st_parameter_dt
*dtp
)
4079 library_start (&dtp
->common
);
4080 data_transfer_init (dtp
, 0);
4083 extern void st_write_done (st_parameter_dt
*);
4084 export_proto(st_write_done
);
4087 st_write_done (st_parameter_dt
*dtp
)
4089 finalize_transfer (dtp
);
4091 if (dtp
->u
.p
.current_unit
!= NULL
4092 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4094 /* Deal with endfile conditions associated with sequential files. */
4095 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4096 switch (dtp
->u
.p
.current_unit
->endfile
)
4098 case AT_ENDFILE
: /* Remain at the endfile record. */
4102 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
4106 /* Get rid of whatever is after this record. */
4107 if (!is_internal_unit (dtp
))
4108 unit_truncate (dtp
->u
.p
.current_unit
,
4109 stell (dtp
->u
.p
.current_unit
->s
),
4111 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4117 /* If this is a parent WRITE statement we do not need to retain the
4118 internal unit structure for child use. Free it and stash the
4119 unit number for reuse. */
4120 if (is_internal_unit (dtp
) &&
4121 (dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4123 free (dtp
->u
.p
.current_unit
->filename
);
4124 dtp
->u
.p
.current_unit
->filename
= NULL
;
4125 free (dtp
->u
.p
.current_unit
->s
);
4126 dtp
->u
.p
.current_unit
->s
= NULL
;
4127 if (dtp
->u
.p
.current_unit
->ls
)
4128 free (dtp
->u
.p
.current_unit
->ls
);
4129 dtp
->u
.p
.current_unit
->ls
= NULL
;
4130 stash_internal_unit (dtp
);
4132 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
4134 free_format_data (dtp
->u
.p
.fmt
);
4137 unlock_unit (dtp
->u
.p
.current_unit
);
4143 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
4145 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
4150 /* Receives the scalar information for namelist objects and stores it
4151 in a linked list of namelist_info types. */
4154 set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4155 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4156 GFC_INTEGER_4 dtype
, void *dtio_sub
, void *vtable
)
4158 namelist_info
*t1
= NULL
;
4160 size_t var_name_len
= strlen (var_name
);
4162 nml
= (namelist_info
*) xmalloc (sizeof (namelist_info
));
4164 nml
->mem_pos
= var_addr
;
4165 nml
->dtio_sub
= dtio_sub
;
4166 nml
->vtable
= vtable
;
4168 nml
->var_name
= (char*) xmalloc (var_name_len
+ 1);
4169 memcpy (nml
->var_name
, var_name
, var_name_len
);
4170 nml
->var_name
[var_name_len
] = '\0';
4172 nml
->len
= (int) len
;
4173 nml
->string_length
= (index_type
) string_length
;
4175 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
4176 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
4177 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
4179 if (nml
->var_rank
> 0)
4181 nml
->dim
= (descriptor_dimension
*)
4182 xmallocarray (nml
->var_rank
, sizeof (descriptor_dimension
));
4183 nml
->ls
= (array_loop_spec
*)
4184 xmallocarray (nml
->var_rank
, sizeof (array_loop_spec
));
4194 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
4196 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
4197 dtp
->u
.p
.ionml
= nml
;
4201 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
4206 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
4207 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
4208 export_proto(st_set_nml_var
);
4211 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4212 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4213 GFC_INTEGER_4 dtype
)
4215 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4220 /* Essentially the same as previous but carrying the dtio procedure
4221 and the vtable as additional arguments. */
4222 extern void st_set_nml_dtio_var (st_parameter_dt
*dtp
, void *, char *,
4223 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
,
4225 export_proto(st_set_nml_dtio_var
);
4229 st_set_nml_dtio_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4230 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4231 GFC_INTEGER_4 dtype
, void *dtio_sub
, void *vtable
)
4233 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4234 dtype
, dtio_sub
, vtable
);
4237 /* Store the dimensional information for the namelist object. */
4238 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
4239 index_type
, index_type
,
4241 export_proto(st_set_nml_var_dim
);
4244 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
4245 index_type stride
, index_type lbound
,
4248 namelist_info
* nml
;
4253 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
4255 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
4259 /* Once upon a time, a poor innocent Fortran program was reading a
4260 file, when suddenly it hit the end-of-file (EOF). Unfortunately
4261 the OS doesn't tell whether we're at the EOF or whether we already
4262 went past it. Luckily our hero, libgfortran, keeps track of this.
4263 Call this function when you detect an EOF condition. See Section
4267 hit_eof (st_parameter_dt
* dtp
)
4269 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
4271 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4272 switch (dtp
->u
.p
.current_unit
->endfile
)
4276 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4277 if (!is_internal_unit (dtp
) && !dtp
->u
.p
.namelist_mode
)
4279 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
4280 dtp
->u
.p
.current_unit
->current_record
= 0;
4283 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4287 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
4288 dtp
->u
.p
.current_unit
->current_record
= 0;
4293 /* Non-sequential files don't have an ENDFILE record, so we
4294 can't be at AFTER_ENDFILE. */
4295 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4296 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4297 dtp
->u
.p
.current_unit
->current_record
= 0;