1 /* Copyright (C) 2002-2016 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. */
40 /* Calling conventions: Data transfer statements are unlike other
41 library calls in that they extend over several calls.
43 The first call is always a call to st_read() or st_write(). These
44 subroutines return no status unless a namelist read or write is
45 being done, in which case there is the usual status. No further
46 calls are necessary in this case.
48 For other sorts of data transfer, there are zero or more data
49 transfer statement that depend on the format of the data transfer
50 statement. For READ (and for backwards compatibily: for WRITE), one has
55 transfer_character_wide
63 transfer_integer_write
64 transfer_logical_write
65 transfer_character_write
66 transfer_character_wide_write
68 transfer_complex_write
69 transfer_real128_write
70 transfer_complex128_write
72 These subroutines do not return status. The *128 functions
73 are in the file transfer128.c.
75 The last call is a call to st_[read|write]_done(). While
76 something can easily go wrong with the initial st_read() or
77 st_write(), an error inhibits any data from actually being
80 extern void transfer_integer (st_parameter_dt
*, void *, int);
81 export_proto(transfer_integer
);
83 extern void transfer_integer_write (st_parameter_dt
*, void *, int);
84 export_proto(transfer_integer_write
);
86 extern void transfer_real (st_parameter_dt
*, void *, int);
87 export_proto(transfer_real
);
89 extern void transfer_real_write (st_parameter_dt
*, void *, int);
90 export_proto(transfer_real_write
);
92 extern void transfer_logical (st_parameter_dt
*, void *, int);
93 export_proto(transfer_logical
);
95 extern void transfer_logical_write (st_parameter_dt
*, void *, int);
96 export_proto(transfer_logical_write
);
98 extern void transfer_character (st_parameter_dt
*, void *, int);
99 export_proto(transfer_character
);
101 extern void transfer_character_write (st_parameter_dt
*, void *, int);
102 export_proto(transfer_character_write
);
104 extern void transfer_character_wide (st_parameter_dt
*, void *, int, int);
105 export_proto(transfer_character_wide
);
107 extern void transfer_character_wide_write (st_parameter_dt
*,
109 export_proto(transfer_character_wide_write
);
111 extern void transfer_complex (st_parameter_dt
*, void *, int);
112 export_proto(transfer_complex
);
114 extern void transfer_complex_write (st_parameter_dt
*, void *, int);
115 export_proto(transfer_complex_write
);
117 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
119 export_proto(transfer_array
);
121 extern void transfer_array_write (st_parameter_dt
*, gfc_array_char
*, int,
123 export_proto(transfer_array_write
);
125 /* User defined derived type input/output. */
127 transfer_derived (st_parameter_dt
*dtp
, void *dtio_source
, void *dtio_proc
);
128 export_proto(transfer_derived
);
131 transfer_derived_write (st_parameter_dt
*dtp
, void *dtio_source
, void *dtio_proc
);
132 export_proto(transfer_derived_write
);
134 static void us_read (st_parameter_dt
*, int);
135 static void us_write (st_parameter_dt
*, int);
136 static void next_record_r_unf (st_parameter_dt
*, int);
137 static void next_record_w_unf (st_parameter_dt
*, int);
139 static const st_option advance_opt
[] = {
140 {"yes", ADVANCE_YES
},
146 static const st_option decimal_opt
[] = {
147 {"point", DECIMAL_POINT
},
148 {"comma", DECIMAL_COMMA
},
152 static const st_option round_opt
[] = {
154 {"down", ROUND_DOWN
},
155 {"zero", ROUND_ZERO
},
156 {"nearest", ROUND_NEAREST
},
157 {"compatible", ROUND_COMPATIBLE
},
158 {"processor_defined", ROUND_PROCDEFINED
},
163 static const st_option sign_opt
[] = {
165 {"suppress", SIGN_SS
},
166 {"processor_defined", SIGN_S
},
170 static const st_option blank_opt
[] = {
171 {"null", BLANK_NULL
},
172 {"zero", BLANK_ZERO
},
176 static const st_option delim_opt
[] = {
177 {"apostrophe", DELIM_APOSTROPHE
},
178 {"quote", DELIM_QUOTE
},
179 {"none", DELIM_NONE
},
183 static const st_option pad_opt
[] = {
190 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
191 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
197 current_mode (st_parameter_dt
*dtp
)
201 m
= FORM_UNSPECIFIED
;
203 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
205 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
206 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
208 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
210 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
211 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
213 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
215 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
216 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
223 /* Mid level data transfer statements. */
225 /* Read sequential file - internal unit */
228 read_sf_internal (st_parameter_dt
*dtp
, int * length
)
230 static char *empty_string
[0];
234 /* Zero size array gives internal unit len of 0. Nothing to read. */
235 if (dtp
->internal_unit_len
== 0
236 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
239 /* If we have seen an eor previously, return a length of 0. The
240 caller is responsible for correctly padding the input field. */
241 if (dtp
->u
.p
.sf_seen_eor
)
244 /* Just return something that isn't a NULL pointer, otherwise the
245 caller thinks an error occurred. */
246 return (char*) empty_string
;
250 if (is_char4_unit(dtp
))
253 gfc_char4_t
*p
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
,
255 base
= fbuf_alloc (dtp
->u
.p
.current_unit
, lorig
);
256 for (i
= 0; i
< *length
; i
++, p
++)
257 base
[i
] = *p
> 255 ? '?' : (unsigned char) *p
;
260 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
262 if (unlikely (lorig
> *length
))
268 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
270 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
271 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *length
;
277 /* When reading sequential formatted records we have a problem. We
278 don't know how long the line is until we read the trailing newline,
279 and we don't want to read too much. If we read too much, we might
280 have to do a physical seek backwards depending on how much data is
281 present, and devices like terminals aren't seekable and would cause
284 Given this, the solution is to read a byte at a time, stopping if
285 we hit the newline. For small allocations, we use a static buffer.
286 For larger allocations, we are forced to allocate memory on the
287 heap. Hopefully this won't happen very often. */
289 /* Read sequential file - external unit */
292 read_sf (st_parameter_dt
*dtp
, int * length
)
294 static char *empty_string
[0];
296 int n
, lorig
, seen_comma
;
298 /* If we have seen an eor previously, return a length of 0. The
299 caller is responsible for correctly padding the input field. */
300 if (dtp
->u
.p
.sf_seen_eor
)
303 /* Just return something that isn't a NULL pointer, otherwise the
304 caller thinks an error occurred. */
305 return (char*) empty_string
;
310 /* Read data into format buffer and scan through it. */
315 q
= fbuf_getc (dtp
->u
.p
.current_unit
);
318 else if (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
.size_used
+= (GFC_IO_INT
) n
;
403 /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
404 fbuf_getc might reallocate the buffer. So return current pointer
405 minus all the advances, which is n plus up to two characters
406 of newline or comma. */
407 return fbuf_getptr (dtp
->u
.p
.current_unit
)
408 - n
- dtp
->u
.p
.sf_seen_eor
- seen_comma
;
412 /* Function for reading the next couple of bytes from the current
413 file, advancing the current position. We return NULL on end of record or
414 end of file. This function is only for formatted I/O, unformatted uses
417 If the read is short, then it is because the current record does not
418 have enough data to satisfy the read request and the file was
419 opened with PAD=YES. The caller must assume tailing spaces for
423 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
428 if (!is_stream_io (dtp
))
430 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
432 /* For preconnected units with default record length, set bytes left
433 to unit record length and proceed, otherwise error. */
434 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
435 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
436 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
439 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
440 && !is_internal_unit (dtp
))
442 /* Not enough data left. */
443 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
448 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0
449 && !is_internal_unit(dtp
)))
455 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
459 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
460 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
461 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
463 if (is_internal_unit (dtp
))
464 source
= read_sf_internal (dtp
, nbytes
);
466 source
= read_sf (dtp
, nbytes
);
468 dtp
->u
.p
.current_unit
->strm_pos
+=
469 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
473 /* If we reach here, we can assume it's direct access. */
475 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
478 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
479 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
481 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
482 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *nbytes
;
484 if (norig
!= *nbytes
)
486 /* Short read, this shouldn't happen. */
487 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
489 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
494 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
500 /* Read a block from a character(kind=4) internal unit, to be transferred into
501 a character(kind=4) variable. Note: Portions of this code borrowed from
504 read_block_form4 (st_parameter_dt
*dtp
, int * nbytes
)
506 static gfc_char4_t
*empty_string
[0];
510 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
511 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
513 /* Zero size array gives internal unit len of 0. Nothing to read. */
514 if (dtp
->internal_unit_len
== 0
515 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
518 /* If we have seen an eor previously, return a length of 0. The
519 caller is responsible for correctly padding the input field. */
520 if (dtp
->u
.p
.sf_seen_eor
)
523 /* Just return something that isn't a NULL pointer, otherwise the
524 caller thinks an error occurred. */
529 source
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
, nbytes
);
531 if (unlikely (lorig
> *nbytes
))
537 dtp
->u
.p
.current_unit
->bytes_left
-= *nbytes
;
539 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
540 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *nbytes
;
546 /* Reads a block directly into application data space. This is for
547 unformatted files. */
550 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
552 ssize_t to_read_record
;
553 ssize_t have_read_record
;
554 ssize_t to_read_subrecord
;
555 ssize_t have_read_subrecord
;
558 if (is_stream_io (dtp
))
560 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
562 if (unlikely (have_read_record
< 0))
564 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
568 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
570 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
572 /* Short read, e.g. if we hit EOF. For stream files,
573 we have to set the end-of-file condition. */
579 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
581 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
584 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
585 nbytes
= to_read_record
;
590 to_read_record
= nbytes
;
593 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
595 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
596 if (unlikely (to_read_record
< 0))
598 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
602 if (to_read_record
!= (ssize_t
) nbytes
)
604 /* Short read, e.g. if we hit EOF. Apparently, we read
605 more than was written to the last record. */
609 if (unlikely (short_record
))
611 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
616 /* Unformatted sequential. We loop over the subrecords, reading
617 until the request has been fulfilled or the record has run out
618 of continuation subrecords. */
620 /* Check whether we exceed the total record length. */
622 if (dtp
->u
.p
.current_unit
->flags
.has_recl
623 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
625 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
630 to_read_record
= nbytes
;
633 have_read_record
= 0;
637 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
638 < (gfc_offset
) to_read_record
)
640 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
641 to_read_record
-= to_read_subrecord
;
645 to_read_subrecord
= to_read_record
;
649 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
651 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
652 buf
+ have_read_record
, to_read_subrecord
);
653 if (unlikely (have_read_subrecord
< 0))
655 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
659 have_read_record
+= have_read_subrecord
;
661 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
663 /* Short read, e.g. if we hit EOF. This means the record
664 structure has been corrupted, or the trailing record
665 marker would still be present. */
667 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
671 if (to_read_record
> 0)
673 if (likely (dtp
->u
.p
.current_unit
->continued
))
675 next_record_r_unf (dtp
, 0);
680 /* Let's make sure the file position is correctly pre-positioned
681 for the next read statement. */
683 dtp
->u
.p
.current_unit
->current_record
= 0;
684 next_record_r_unf (dtp
, 0);
685 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
691 /* Normal exit, the read request has been fulfilled. */
696 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
697 if (unlikely (short_record
))
699 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
706 /* Function for writing a block of bytes to the current file at the
707 current position, advancing the file pointer. We are given a length
708 and return a pointer to a buffer that the caller must (completely)
709 fill in. Returns NULL on error. */
712 write_block (st_parameter_dt
*dtp
, int length
)
716 if (!is_stream_io (dtp
))
718 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
720 /* For preconnected units with default record length, set bytes left
721 to unit record length and proceed, otherwise error. */
722 if (likely ((dtp
->u
.p
.current_unit
->unit_number
723 == options
.stdout_unit
724 || dtp
->u
.p
.current_unit
->unit_number
725 == options
.stderr_unit
)
726 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
727 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
730 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
735 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
738 if (is_internal_unit (dtp
))
740 if (is_char4_unit(dtp
)) /* char4 internel unit. */
743 dest4
= mem_alloc_w4 (dtp
->u
.p
.current_unit
->s
, &length
);
746 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
752 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
756 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
760 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
761 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
765 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
768 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
773 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
774 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) length
;
776 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
782 /* High level interface to swrite(), taking care of errors. This is only
783 called for unformatted files. There are three cases to consider:
784 Stream I/O, unformatted direct, unformatted sequential. */
787 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
790 ssize_t have_written
;
791 ssize_t to_write_subrecord
;
796 if (is_stream_io (dtp
))
798 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
799 if (unlikely (have_written
< 0))
801 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
805 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
810 /* Unformatted direct access. */
812 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
814 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
816 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
820 if (buf
== NULL
&& nbytes
== 0)
823 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
824 if (unlikely (have_written
< 0))
826 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
830 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
831 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
836 /* Unformatted sequential. */
840 if (dtp
->u
.p
.current_unit
->flags
.has_recl
841 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
843 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
855 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
856 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
858 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
859 (gfc_offset
) to_write_subrecord
;
861 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
862 buf
+ have_written
, to_write_subrecord
);
863 if (unlikely (to_write_subrecord
< 0))
865 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
869 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
870 nbytes
-= to_write_subrecord
;
871 have_written
+= to_write_subrecord
;
876 next_record_w_unf (dtp
, 1);
879 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
880 if (unlikely (short_record
))
882 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
889 /* Reverse memcpy - used for byte swapping. */
892 reverse_memcpy (void *dest
, const void *src
, size_t n
)
898 s
= (char *) src
+ n
- 1;
900 /* Write with ascending order - this is likely faster
901 on modern architectures because of write combining. */
907 /* Utility function for byteswapping an array, using the bswap
908 builtins if possible. dest and src can overlap completely, or then
909 they must point to separate objects; partial overlaps are not
913 bswap_array (void *dest
, const void *src
, size_t size
, size_t nelems
)
923 for (size_t i
= 0; i
< nelems
; i
++)
924 ((uint16_t*)dest
)[i
] = __builtin_bswap16 (((uint16_t*)src
)[i
]);
927 for (size_t i
= 0; i
< nelems
; i
++)
928 ((uint32_t*)dest
)[i
] = __builtin_bswap32 (((uint32_t*)src
)[i
]);
931 for (size_t i
= 0; i
< nelems
; i
++)
932 ((uint64_t*)dest
)[i
] = __builtin_bswap64 (((uint64_t*)src
)[i
]);
937 for (size_t i
= 0; i
< nelems
; i
++)
940 memcpy (&tmp
, ps
, 4);
941 *(uint32_t*)pd
= __builtin_bswap32 (*(uint32_t*)(ps
+ 8));
942 *(uint32_t*)(pd
+ 4) = __builtin_bswap32 (*(uint32_t*)(ps
+ 4));
943 *(uint32_t*)(pd
+ 8) = __builtin_bswap32 (tmp
);
951 for (size_t i
= 0; i
< nelems
; i
++)
954 memcpy (&tmp
, ps
, 8);
955 *(uint64_t*)pd
= __builtin_bswap64 (*(uint64_t*)(ps
+ 8));
956 *(uint64_t*)(pd
+ 8) = __builtin_bswap64 (tmp
);
966 for (size_t i
= 0; i
< nelems
; i
++)
968 reverse_memcpy (pd
, ps
, size
);
975 /* In-place byte swap. */
976 for (size_t i
= 0; i
< nelems
; i
++)
978 char tmp
, *low
= pd
, *high
= pd
+ size
- 1;
979 for (size_t j
= 0; j
< size
/2; j
++)
994 /* Master function for unformatted reads. */
997 unformatted_read (st_parameter_dt
*dtp
, bt type
,
998 void *dest
, int kind
, size_t size
, size_t nelems
)
1000 if (type
== BT_CLASS
)
1002 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1003 char tmp_iomsg
[IOMSG_LEN
] = "";
1005 gfc_charlen_type child_iomsg_len
;
1007 int *child_iostat
= NULL
;
1009 /* Set iostat, intent(out). */
1011 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1012 dtp
->common
.iostat
: &noiostat
;
1014 /* Set iomsg, intent(inout). */
1015 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1017 child_iomsg
= dtp
->common
.iomsg
;
1018 child_iomsg_len
= dtp
->common
.iomsg_len
;
1022 child_iomsg
= tmp_iomsg
;
1023 child_iomsg_len
= IOMSG_LEN
;
1026 /* Call the user defined unformatted READ procedure. */
1027 dtp
->u
.p
.current_unit
->child_dtio
++;
1028 dtp
->u
.p
.ufdtio_ptr (dest
, &unit
, child_iostat
, child_iomsg
,
1030 dtp
->u
.p
.current_unit
->child_dtio
--;
1034 if (type
== BT_CHARACTER
)
1035 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
1036 read_block_direct (dtp
, dest
, size
* nelems
);
1038 if (unlikely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_SWAP
)
1041 /* Handle wide chracters. */
1042 if (type
== BT_CHARACTER
)
1048 /* Break up complex into its constituent reals. */
1049 else if (type
== BT_COMPLEX
)
1054 bswap_array (dest
, dest
, size
, nelems
);
1059 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
1060 bytes on 64 bit machines. The unused bytes are not initialized and never
1061 used, which can show an error with memory checking analyzers like
1062 valgrind. We us BT_CLASS to denote a User Defined I/O call. */
1065 unformatted_write (st_parameter_dt
*dtp
, bt type
,
1066 void *source
, int kind
, size_t size
, size_t nelems
)
1068 if (type
== BT_CLASS
)
1070 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1071 char tmp_iomsg
[IOMSG_LEN
] = "";
1073 gfc_charlen_type child_iomsg_len
;
1075 int *child_iostat
= NULL
;
1077 /* Set iostat, intent(out). */
1079 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1080 dtp
->common
.iostat
: &noiostat
;
1082 /* Set iomsg, intent(inout). */
1083 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1085 child_iomsg
= dtp
->common
.iomsg
;
1086 child_iomsg_len
= dtp
->common
.iomsg_len
;
1090 child_iomsg
= tmp_iomsg
;
1091 child_iomsg_len
= IOMSG_LEN
;
1094 /* Call the user defined unformatted WRITE procedure. */
1095 dtp
->u
.p
.current_unit
->child_dtio
++;
1096 dtp
->u
.p
.ufdtio_ptr (source
, &unit
, child_iostat
, child_iomsg
,
1098 dtp
->u
.p
.current_unit
->child_dtio
--;
1102 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1105 size_t stride
= type
== BT_CHARACTER
?
1106 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1108 write_buf (dtp
, source
, stride
* nelems
);
1112 #define BSWAP_BUFSZ 512
1113 char buffer
[BSWAP_BUFSZ
];
1119 /* Handle wide chracters. */
1120 if (type
== BT_CHARACTER
&& kind
!= 1)
1126 /* Break up complex into its constituent reals. */
1127 if (type
== BT_COMPLEX
)
1133 /* By now, all complex variables have been split into their
1134 constituent reals. */
1140 if (size
* nrem
> BSWAP_BUFSZ
)
1141 nc
= BSWAP_BUFSZ
/ size
;
1145 bswap_array (buffer
, p
, size
, nc
);
1146 write_buf (dtp
, buffer
, size
* nc
);
1155 /* Return a pointer to the name of a type. */
1180 p
= "CLASS or DERIVED";
1183 internal_error (NULL
, "type_name(): Bad type");
1190 /* Write a constant string to the output.
1191 This is complicated because the string can have doubled delimiters
1192 in it. The length in the format node is the true length. */
1195 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
1197 char c
, delimiter
, *p
, *q
;
1200 length
= f
->u
.string
.length
;
1204 p
= write_block (dtp
, length
);
1211 for (; length
> 0; length
--)
1214 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
1215 q
++; /* Skip the doubled delimiter. */
1220 /* Given actual and expected types in a formatted data transfer, make
1221 sure they agree. If not, an error message is generated. Returns
1222 nonzero if something went wrong. */
1225 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
1228 char buffer
[BUFLEN
];
1230 if (actual
== expected
)
1233 /* Adjust item_count before emitting error message. */
1234 snprintf (buffer
, BUFLEN
,
1235 "Expected %s for item %d in formatted transfer, got %s",
1236 type_name (expected
), dtp
->u
.p
.item_count
- 1, type_name (actual
));
1238 format_error (dtp
, f
, buffer
);
1244 require_numeric_type (st_parameter_dt
*dtp
, bt actual
, const fnode
*f
)
1247 char buffer
[BUFLEN
];
1249 if (actual
== BT_INTEGER
|| actual
== BT_REAL
|| actual
== BT_COMPLEX
)
1252 /* Adjust item_count before emitting error message. */
1253 snprintf (buffer
, BUFLEN
,
1254 "Expected numeric type for item %d in formatted transfer, got %s",
1255 dtp
->u
.p
.item_count
- 1, type_name (actual
));
1257 format_error (dtp
, f
, buffer
);
1262 /* This function is in the main loop for a formatted data transfer
1263 statement. It would be natural to implement this as a coroutine
1264 with the user program, but C makes that awkward. We loop,
1265 processing format elements. When we actually have to transfer
1266 data instead of just setting flags, we return control to the user
1267 program which calls a function that supplies the address and type
1268 of the next element, then comes back here to process it. */
1271 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1274 int pos
, bytes_used
;
1278 int consume_data_flag
;
1280 /* Change a complex data item into a pair of reals. */
1282 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1283 if (type
== BT_COMPLEX
)
1289 /* If there's an EOR condition, we simulate finalizing the transfer
1290 by doing nothing. */
1291 if (dtp
->u
.p
.eor_condition
)
1294 /* Set this flag so that commas in reads cause the read to complete before
1295 the entire field has been read. The next read field will start right after
1296 the comma in the stream. (Set to 0 for character reads). */
1297 dtp
->u
.p
.sf_read_comma
=
1298 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1302 /* If reversion has occurred and there is another real data item,
1303 then we have to move to the next record. */
1304 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1306 dtp
->u
.p
.reversion_flag
= 0;
1307 next_record (dtp
, 0);
1310 consume_data_flag
= 1;
1311 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1314 f
= next_format (dtp
);
1317 /* No data descriptors left. */
1318 if (unlikely (n
> 0))
1319 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1320 "Insufficient data descriptors in format after reversion");
1326 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1327 - dtp
->u
.p
.current_unit
->bytes_left
);
1329 if (is_stream_io(dtp
))
1336 goto need_read_data
;
1337 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1339 read_decimal (dtp
, f
, p
, kind
);
1344 goto need_read_data
;
1345 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1346 && require_numeric_type (dtp
, type
, f
))
1348 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1349 && require_type (dtp
, BT_INTEGER
, type
, f
))
1351 read_radix (dtp
, f
, p
, kind
, 2);
1356 goto need_read_data
;
1357 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1358 && require_numeric_type (dtp
, type
, f
))
1360 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1361 && require_type (dtp
, BT_INTEGER
, type
, f
))
1363 read_radix (dtp
, f
, p
, kind
, 8);
1368 goto need_read_data
;
1369 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1370 && require_numeric_type (dtp
, type
, f
))
1372 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1373 && require_type (dtp
, BT_INTEGER
, type
, f
))
1375 read_radix (dtp
, f
, p
, kind
, 16);
1380 goto need_read_data
;
1382 /* It is possible to have FMT_A with something not BT_CHARACTER such
1383 as when writing out hollerith strings, so check both type
1384 and kind before calling wide character routines. */
1385 if (type
== BT_CHARACTER
&& kind
== 4)
1386 read_a_char4 (dtp
, f
, p
, size
);
1388 read_a (dtp
, f
, p
, size
);
1393 goto need_read_data
;
1394 read_l (dtp
, f
, p
, kind
);
1399 goto need_read_data
;
1400 if (require_type (dtp
, BT_REAL
, type
, f
))
1402 read_f (dtp
, f
, p
, kind
);
1407 goto need_read_data
;
1408 if (require_type (dtp
, BT_CLASS
, type
, f
))
1410 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1412 char tmp_iomsg
[IOMSG_LEN
] = "";
1414 gfc_charlen_type child_iomsg_len
;
1416 int *child_iostat
= NULL
;
1417 char *iotype
= f
->u
.udf
.string
;
1418 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1420 /* Build the iotype string. */
1421 if (iotype_len
== 0)
1429 iotype
= xmalloc (iotype_len
);
1432 memcpy (iotype
+ 2, f
->u
.udf
.string
, f
->u
.udf
.string_len
);
1435 /* Set iostat, intent(out). */
1437 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1438 dtp
->common
.iostat
: &noiostat
;
1440 /* Set iomsg, intent(inout). */
1441 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1443 child_iomsg
= dtp
->common
.iomsg
;
1444 child_iomsg_len
= dtp
->common
.iomsg_len
;
1448 child_iomsg
= tmp_iomsg
;
1449 child_iomsg_len
= IOMSG_LEN
;
1452 /* Call the user defined formatted READ procedure. */
1453 dtp
->u
.p
.current_unit
->child_dtio
++;
1454 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1455 child_iostat
, child_iomsg
,
1456 iotype_len
, child_iomsg_len
);
1457 dtp
->u
.p
.current_unit
->child_dtio
--;
1459 if (f
->u
.udf
.string_len
!= 0)
1461 /* Note: vlist is freed in free_format_data. */
1466 goto need_read_data
;
1467 if (require_type (dtp
, BT_REAL
, type
, f
))
1469 read_f (dtp
, f
, p
, kind
);
1474 goto need_read_data
;
1475 if (require_type (dtp
, BT_REAL
, type
, f
))
1477 read_f (dtp
, f
, p
, kind
);
1482 goto need_read_data
;
1483 if (require_type (dtp
, BT_REAL
, type
, f
))
1485 read_f (dtp
, f
, p
, kind
);
1490 goto need_read_data
;
1491 if (require_type (dtp
, BT_REAL
, type
, f
))
1493 read_f (dtp
, f
, p
, kind
);
1498 goto need_read_data
;
1502 read_decimal (dtp
, f
, p
, kind
);
1505 read_l (dtp
, f
, p
, kind
);
1509 read_a_char4 (dtp
, f
, p
, size
);
1511 read_a (dtp
, f
, p
, size
);
1514 read_f (dtp
, f
, p
, kind
);
1517 internal_error (&dtp
->common
, "formatted_transfer(): Bad type");
1522 consume_data_flag
= 0;
1523 format_error (dtp
, f
, "Constant string in input format");
1526 /* Format codes that don't transfer data. */
1529 consume_data_flag
= 0;
1530 dtp
->u
.p
.skips
+= f
->u
.n
;
1531 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1532 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1533 read_x (dtp
, f
->u
.n
);
1538 consume_data_flag
= 0;
1540 if (f
->format
== FMT_TL
)
1542 /* Handle the special case when no bytes have been used yet.
1543 Cannot go below zero. */
1544 if (bytes_used
== 0)
1546 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1547 dtp
->u
.p
.skips
-= f
->u
.n
;
1548 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1551 pos
= bytes_used
- f
->u
.n
;
1556 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1557 left tab limit. We do not check if the position has gone
1558 beyond the end of record because a subsequent tab could
1559 bring us back again. */
1560 pos
= pos
< 0 ? 0 : pos
;
1562 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1563 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1564 + pos
- dtp
->u
.p
.max_pos
;
1565 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1566 ? 0 : dtp
->u
.p
.pending_spaces
;
1567 if (dtp
->u
.p
.skips
== 0)
1570 /* Adjust everything for end-of-record condition */
1571 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1573 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1574 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1576 dtp
->u
.p
.sf_seen_eor
= 0;
1578 if (dtp
->u
.p
.skips
< 0)
1580 if (is_internal_unit (dtp
))
1581 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1583 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1584 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1585 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1588 read_x (dtp
, dtp
->u
.p
.skips
);
1592 consume_data_flag
= 0;
1593 dtp
->u
.p
.sign_status
= SIGN_S
;
1597 consume_data_flag
= 0;
1598 dtp
->u
.p
.sign_status
= SIGN_SS
;
1602 consume_data_flag
= 0;
1603 dtp
->u
.p
.sign_status
= SIGN_SP
;
1607 consume_data_flag
= 0 ;
1608 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1612 consume_data_flag
= 0;
1613 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1617 consume_data_flag
= 0;
1618 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1622 consume_data_flag
= 0;
1623 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1627 consume_data_flag
= 0;
1628 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1632 consume_data_flag
= 0;
1633 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1637 consume_data_flag
= 0;
1638 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1642 consume_data_flag
= 0;
1643 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1647 consume_data_flag
= 0;
1648 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1652 consume_data_flag
= 0;
1653 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1657 consume_data_flag
= 0;
1658 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1662 consume_data_flag
= 0;
1663 dtp
->u
.p
.seen_dollar
= 1;
1667 consume_data_flag
= 0;
1668 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1669 next_record (dtp
, 0);
1673 /* A colon descriptor causes us to exit this loop (in
1674 particular preventing another / descriptor from being
1675 processed) unless there is another data item to be
1677 consume_data_flag
= 0;
1683 internal_error (&dtp
->common
, "Bad format node");
1686 /* Adjust the item count and data pointer. */
1688 if ((consume_data_flag
> 0) && (n
> 0))
1691 p
= ((char *) p
) + size
;
1696 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1697 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1702 /* Come here when we need a data descriptor but don't have one. We
1703 push the current format node back onto the input, then return and
1704 let the user program call us back with the data. */
1706 unget_format (dtp
, f
);
1711 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1714 int pos
, bytes_used
;
1718 int consume_data_flag
;
1720 /* Change a complex data item into a pair of reals. */
1722 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1723 if (type
== BT_COMPLEX
)
1729 /* If there's an EOR condition, we simulate finalizing the transfer
1730 by doing nothing. */
1731 if (dtp
->u
.p
.eor_condition
)
1734 /* Set this flag so that commas in reads cause the read to complete before
1735 the entire field has been read. The next read field will start right after
1736 the comma in the stream. (Set to 0 for character reads). */
1737 dtp
->u
.p
.sf_read_comma
=
1738 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1742 /* If reversion has occurred and there is another real data item,
1743 then we have to move to the next record. */
1744 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1746 dtp
->u
.p
.reversion_flag
= 0;
1747 next_record (dtp
, 0);
1750 consume_data_flag
= 1;
1751 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1754 f
= next_format (dtp
);
1757 /* No data descriptors left. */
1758 if (unlikely (n
> 0))
1759 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1760 "Insufficient data descriptors in format after reversion");
1764 /* Now discharge T, TR and X movements to the right. This is delayed
1765 until a data producing format to suppress trailing spaces. */
1768 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1769 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1770 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1771 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1772 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
1774 || t
== FMT_STRING
))
1776 if (dtp
->u
.p
.skips
> 0)
1779 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1780 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1781 - dtp
->u
.p
.current_unit
->bytes_left
);
1783 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1786 if (dtp
->u
.p
.skips
< 0)
1788 if (is_internal_unit (dtp
))
1789 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1791 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1792 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1794 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1797 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1798 - dtp
->u
.p
.current_unit
->bytes_left
);
1800 if (is_stream_io(dtp
))
1808 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1810 write_i (dtp
, f
, p
, kind
);
1816 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1817 && require_numeric_type (dtp
, type
, f
))
1819 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1820 && require_type (dtp
, BT_INTEGER
, type
, f
))
1822 write_b (dtp
, f
, p
, kind
);
1828 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1829 && require_numeric_type (dtp
, type
, f
))
1831 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1832 && require_type (dtp
, BT_INTEGER
, type
, f
))
1834 write_o (dtp
, f
, p
, kind
);
1840 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1841 && require_numeric_type (dtp
, type
, f
))
1843 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1844 && require_type (dtp
, BT_INTEGER
, type
, f
))
1846 write_z (dtp
, f
, p
, kind
);
1853 /* It is possible to have FMT_A with something not BT_CHARACTER such
1854 as when writing out hollerith strings, so check both type
1855 and kind before calling wide character routines. */
1856 if (type
== BT_CHARACTER
&& kind
== 4)
1857 write_a_char4 (dtp
, f
, p
, size
);
1859 write_a (dtp
, f
, p
, size
);
1865 write_l (dtp
, f
, p
, kind
);
1871 if (require_type (dtp
, BT_REAL
, type
, f
))
1873 write_d (dtp
, f
, p
, kind
);
1879 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1881 char tmp_iomsg
[IOMSG_LEN
] = "";
1883 gfc_charlen_type child_iomsg_len
;
1885 int *child_iostat
= NULL
;
1886 char *iotype
= f
->u
.udf
.string
;
1887 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1889 /* Build the iotype string. */
1890 if (iotype_len
== 0)
1898 iotype
= xmalloc (iotype_len
);
1901 memcpy (iotype
+ 2, f
->u
.udf
.string
, f
->u
.udf
.string_len
);
1904 /* Set iostat, intent(out). */
1906 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1907 dtp
->common
.iostat
: &noiostat
;
1909 /* Set iomsg, intent(inout). */
1910 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1912 child_iomsg
= dtp
->common
.iomsg
;
1913 child_iomsg_len
= dtp
->common
.iomsg_len
;
1917 child_iomsg
= tmp_iomsg
;
1918 child_iomsg_len
= IOMSG_LEN
;
1921 /* Call the user defined formatted WRITE procedure. */
1922 dtp
->u
.p
.current_unit
->child_dtio
++;
1923 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1924 child_iostat
, child_iomsg
,
1925 iotype_len
, child_iomsg_len
);
1926 dtp
->u
.p
.current_unit
->child_dtio
--;
1928 if (f
->u
.udf
.string_len
!= 0)
1930 /* Note: vlist is freed in free_format_data. */
1936 if (require_type (dtp
, BT_REAL
, type
, f
))
1938 write_e (dtp
, f
, p
, kind
);
1944 if (require_type (dtp
, BT_REAL
, type
, f
))
1946 write_en (dtp
, f
, p
, kind
);
1952 if (require_type (dtp
, BT_REAL
, type
, f
))
1954 write_es (dtp
, f
, p
, kind
);
1960 if (require_type (dtp
, BT_REAL
, type
, f
))
1962 write_f (dtp
, f
, p
, kind
);
1971 write_i (dtp
, f
, p
, kind
);
1974 write_l (dtp
, f
, p
, kind
);
1978 write_a_char4 (dtp
, f
, p
, size
);
1980 write_a (dtp
, f
, p
, size
);
1983 if (f
->u
.real
.w
== 0)
1984 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1986 write_d (dtp
, f
, p
, kind
);
1989 internal_error (&dtp
->common
,
1990 "formatted_transfer(): Bad type");
1995 consume_data_flag
= 0;
1996 write_constant_string (dtp
, f
);
1999 /* Format codes that don't transfer data. */
2002 consume_data_flag
= 0;
2004 dtp
->u
.p
.skips
+= f
->u
.n
;
2005 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
2006 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
2007 /* Writes occur just before the switch on f->format, above, so
2008 that trailing blanks are suppressed, unless we are doing a
2009 non-advancing write in which case we want to output the blanks
2011 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2013 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
2014 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2020 consume_data_flag
= 0;
2022 if (f
->format
== FMT_TL
)
2025 /* Handle the special case when no bytes have been used yet.
2026 Cannot go below zero. */
2027 if (bytes_used
== 0)
2029 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
2030 dtp
->u
.p
.skips
-= f
->u
.n
;
2031 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
2034 pos
= bytes_used
- f
->u
.n
;
2037 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
2039 /* Standard 10.6.1.1: excessive left tabbing is reset to the
2040 left tab limit. We do not check if the position has gone
2041 beyond the end of record because a subsequent tab could
2042 bring us back again. */
2043 pos
= pos
< 0 ? 0 : pos
;
2045 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
2046 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
2047 + pos
- dtp
->u
.p
.max_pos
;
2048 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
2049 ? 0 : dtp
->u
.p
.pending_spaces
;
2053 consume_data_flag
= 0;
2054 dtp
->u
.p
.sign_status
= SIGN_S
;
2058 consume_data_flag
= 0;
2059 dtp
->u
.p
.sign_status
= SIGN_SS
;
2063 consume_data_flag
= 0;
2064 dtp
->u
.p
.sign_status
= SIGN_SP
;
2068 consume_data_flag
= 0 ;
2069 dtp
->u
.p
.blank_status
= BLANK_NULL
;
2073 consume_data_flag
= 0;
2074 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
2078 consume_data_flag
= 0;
2079 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
2083 consume_data_flag
= 0;
2084 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
2088 consume_data_flag
= 0;
2089 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
2093 consume_data_flag
= 0;
2094 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
2098 consume_data_flag
= 0;
2099 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
2103 consume_data_flag
= 0;
2104 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
2108 consume_data_flag
= 0;
2109 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
2113 consume_data_flag
= 0;
2114 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
2118 consume_data_flag
= 0;
2119 dtp
->u
.p
.scale_factor
= f
->u
.k
;
2123 consume_data_flag
= 0;
2124 dtp
->u
.p
.seen_dollar
= 1;
2128 consume_data_flag
= 0;
2129 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2130 next_record (dtp
, 0);
2134 /* A colon descriptor causes us to exit this loop (in
2135 particular preventing another / descriptor from being
2136 processed) unless there is another data item to be
2138 consume_data_flag
= 0;
2144 internal_error (&dtp
->common
, "Bad format node");
2147 /* Adjust the item count and data pointer. */
2149 if ((consume_data_flag
> 0) && (n
> 0))
2152 p
= ((char *) p
) + size
;
2155 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
2156 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
2161 /* Come here when we need a data descriptor but don't have one. We
2162 push the current format node back onto the input, then return and
2163 let the user program call us back with the data. */
2165 unget_format (dtp
, f
);
2168 /* This function is first called from data_init_transfer to initiate the loop
2169 over each item in the format, transferring data as required. Subsequent
2170 calls to this function occur for each data item foound in the READ/WRITE
2171 statement. The item_count is incremented for each call. Since the first
2172 call is from data_transfer_init, the item_count is always one greater than
2173 the actual count number of the item being transferred. */
2176 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2177 size_t size
, size_t nelems
)
2183 size_t stride
= type
== BT_CHARACTER
?
2184 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2185 if (dtp
->u
.p
.mode
== READING
)
2187 /* Big loop over all the elements. */
2188 for (elem
= 0; elem
< nelems
; elem
++)
2190 dtp
->u
.p
.item_count
++;
2191 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2196 /* Big loop over all the elements. */
2197 for (elem
= 0; elem
< nelems
; elem
++)
2199 dtp
->u
.p
.item_count
++;
2200 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2206 /* Data transfer entry points. The type of the data entity is
2207 implicit in the subroutine call. This prevents us from having to
2208 share a common enum with the compiler. */
2211 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
2213 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2215 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
2219 transfer_integer_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2221 transfer_integer (dtp
, p
, kind
);
2225 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
2228 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2230 size
= size_from_real_kind (kind
);
2231 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
2235 transfer_real_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2237 transfer_real (dtp
, p
, kind
);
2241 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
2243 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2245 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
2249 transfer_logical_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2251 transfer_logical (dtp
, p
, kind
);
2255 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
2257 static char *empty_string
[0];
2259 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2262 /* Strings of zero length can have p == NULL, which confuses the
2263 transfer routines into thinking we need more data elements. To avoid
2264 this, we give them a nice pointer. */
2265 if (len
== 0 && p
== NULL
)
2268 /* Set kind here to 1. */
2269 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
2273 transfer_character_write (st_parameter_dt
*dtp
, void *p
, int len
)
2275 transfer_character (dtp
, p
, len
);
2279 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2281 static char *empty_string
[0];
2283 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2286 /* Strings of zero length can have p == NULL, which confuses the
2287 transfer routines into thinking we need more data elements. To avoid
2288 this, we give them a nice pointer. */
2289 if (len
== 0 && p
== NULL
)
2292 /* Here we pass the actual kind value. */
2293 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
2297 transfer_character_wide_write (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2299 transfer_character_wide (dtp
, p
, len
, kind
);
2303 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
2306 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2308 size
= size_from_complex_kind (kind
);
2309 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
2313 transfer_complex_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2315 transfer_complex (dtp
, p
, kind
);
2319 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2320 gfc_charlen_type charlen
)
2322 index_type count
[GFC_MAX_DIMENSIONS
];
2323 index_type extent
[GFC_MAX_DIMENSIONS
];
2324 index_type stride
[GFC_MAX_DIMENSIONS
];
2325 index_type stride0
, rank
, size
, n
;
2330 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2333 iotype
= (bt
) GFC_DESCRIPTOR_TYPE (desc
);
2334 size
= iotype
== BT_CHARACTER
? charlen
: GFC_DESCRIPTOR_SIZE (desc
);
2336 rank
= GFC_DESCRIPTOR_RANK (desc
);
2337 for (n
= 0; n
< rank
; n
++)
2340 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
2341 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
2343 /* If the extent of even one dimension is zero, then the entire
2344 array section contains zero elements, so we return after writing
2345 a zero array record. */
2350 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2355 stride0
= stride
[0];
2357 /* If the innermost dimension has a stride of 1, we can do the transfer
2358 in contiguous chunks. */
2359 if (stride0
== size
)
2364 data
= GFC_DESCRIPTOR_DATA (desc
);
2368 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2369 data
+= stride0
* tsize
;
2372 while (count
[n
] == extent
[n
])
2375 data
-= stride
[n
] * extent
[n
];
2392 transfer_array_write (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2393 gfc_charlen_type charlen
)
2395 transfer_array (dtp
, desc
, kind
, charlen
);
2399 /* User defined input/output iomsg. */
2401 #define IOMSG_LEN 256
2404 transfer_derived (st_parameter_dt
*parent
, void *dtio_source
, void *dtio_proc
)
2406 if (parent
->u
.p
.current_unit
)
2408 if (parent
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2409 parent
->u
.p
.ufdtio_ptr
= (unformatted_dtio
) dtio_proc
;
2411 parent
->u
.p
.fdtio_ptr
= (formatted_dtio
) dtio_proc
;
2413 parent
->u
.p
.transfer (parent
, BT_CLASS
, dtio_source
, 0, 0, 1);
2417 /* Preposition a sequential unformatted file while reading. */
2420 us_read (st_parameter_dt
*dtp
, int continued
)
2427 if (compile_options
.record_marker
== 0)
2428 n
= sizeof (GFC_INTEGER_4
);
2430 n
= compile_options
.record_marker
;
2432 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
2433 if (unlikely (nr
< 0))
2435 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2441 return; /* end of file */
2443 else if (unlikely (n
!= nr
))
2445 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2449 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2450 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2454 case sizeof(GFC_INTEGER_4
):
2455 memcpy (&i4
, &i
, sizeof (i4
));
2459 case sizeof(GFC_INTEGER_8
):
2460 memcpy (&i8
, &i
, sizeof (i8
));
2465 runtime_error ("Illegal value for record marker");
2475 case sizeof(GFC_INTEGER_4
):
2476 memcpy (&u32
, &i
, sizeof (u32
));
2477 u32
= __builtin_bswap32 (u32
);
2478 memcpy (&i4
, &u32
, sizeof (i4
));
2482 case sizeof(GFC_INTEGER_8
):
2483 memcpy (&u64
, &i
, sizeof (u64
));
2484 u64
= __builtin_bswap64 (u64
);
2485 memcpy (&i8
, &u64
, sizeof (i8
));
2490 runtime_error ("Illegal value for record marker");
2497 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
2498 dtp
->u
.p
.current_unit
->continued
= 0;
2502 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
2503 dtp
->u
.p
.current_unit
->continued
= 1;
2507 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2511 /* Preposition a sequential unformatted file while writing. This
2512 amount to writing a bogus length that will be filled in later. */
2515 us_write (st_parameter_dt
*dtp
, int continued
)
2522 if (compile_options
.record_marker
== 0)
2523 nbytes
= sizeof (GFC_INTEGER_4
);
2525 nbytes
= compile_options
.record_marker
;
2527 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2528 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2530 /* For sequential unformatted, if RECL= was not specified in the OPEN
2531 we write until we have more bytes than can fit in the subrecord
2532 markers, then we write a new subrecord. */
2534 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2535 dtp
->u
.p
.current_unit
->recl_subrecord
;
2536 dtp
->u
.p
.current_unit
->continued
= continued
;
2540 /* Position to the next record prior to transfer. We are assumed to
2541 be before the next record. We also calculate the bytes in the next
2545 pre_position (st_parameter_dt
*dtp
)
2547 if (dtp
->u
.p
.current_unit
->current_record
)
2548 return; /* Already positioned. */
2550 switch (current_mode (dtp
))
2552 case FORMATTED_STREAM
:
2553 case UNFORMATTED_STREAM
:
2554 /* There are no records with stream I/O. If the position was specified
2555 data_transfer_init has already positioned the file. If no position
2556 was specified, we continue from where we last left off. I.e.
2557 there is nothing to do here. */
2560 case UNFORMATTED_SEQUENTIAL
:
2561 if (dtp
->u
.p
.mode
== READING
)
2568 case FORMATTED_SEQUENTIAL
:
2569 case FORMATTED_DIRECT
:
2570 case UNFORMATTED_DIRECT
:
2571 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2575 dtp
->u
.p
.current_unit
->current_record
= 1;
2579 /* Initialize things for a data transfer. This code is common for
2580 both reading and writing. */
2583 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2585 unit_flags u_flags
; /* Used for creating a unit if needed. */
2586 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2587 namelist_info
*ionml
;
2589 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2591 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2593 dtp
->u
.p
.ionml
= ionml
;
2594 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2596 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2599 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2600 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
2602 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2604 if (dtp
->u
.p
.current_unit
== NULL
)
2606 /* This means we tried to access an external unit < 0 without
2607 having opened it first with NEWUNIT=. */
2608 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2609 "Invalid unit number in statement");
2612 else if (dtp
->u
.p
.current_unit
->s
== NULL
)
2613 { /* Open the unit with some default flags. */
2614 st_parameter_open opp
;
2617 if (dtp
->common
.unit
< 0 && !is_internal_unit (dtp
))
2619 close_unit (dtp
->u
.p
.current_unit
);
2620 dtp
->u
.p
.current_unit
= NULL
;
2621 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2622 "Bad unit number in statement");
2625 memset (&u_flags
, '\0', sizeof (u_flags
));
2626 u_flags
.access
= ACCESS_SEQUENTIAL
;
2627 u_flags
.action
= ACTION_READWRITE
;
2629 /* Is it unformatted? */
2630 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2631 | IOPARM_DT_IONML_SET
)))
2632 u_flags
.form
= FORM_UNFORMATTED
;
2634 u_flags
.form
= FORM_UNSPECIFIED
;
2636 u_flags
.delim
= DELIM_UNSPECIFIED
;
2637 u_flags
.blank
= BLANK_UNSPECIFIED
;
2638 u_flags
.pad
= PAD_UNSPECIFIED
;
2639 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2640 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2641 u_flags
.async
= ASYNC_UNSPECIFIED
;
2642 u_flags
.round
= ROUND_UNSPECIFIED
;
2643 u_flags
.sign
= SIGN_UNSPECIFIED
;
2645 u_flags
.status
= STATUS_UNKNOWN
;
2647 conv
= get_unformatted_convert (dtp
->common
.unit
);
2649 if (conv
== GFC_CONVERT_NONE
)
2650 conv
= compile_options
.convert
;
2652 /* We use big_endian, which is 0 on little-endian machines
2653 and 1 on big-endian machines. */
2656 case GFC_CONVERT_NATIVE
:
2657 case GFC_CONVERT_SWAP
:
2660 case GFC_CONVERT_BIG
:
2661 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2664 case GFC_CONVERT_LITTLE
:
2665 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2669 internal_error (&opp
.common
, "Illegal value for CONVERT");
2673 u_flags
.convert
= conv
;
2675 opp
.common
= dtp
->common
;
2676 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2677 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2678 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2679 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2680 if (dtp
->u
.p
.current_unit
== NULL
)
2684 /* Check the action. */
2686 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2688 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2689 "Cannot read from file opened for WRITE");
2693 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2695 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2696 "Cannot write to file opened for READ");
2700 dtp
->u
.p
.first_item
= 1;
2702 /* Check the format. */
2704 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2707 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2708 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2711 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2712 "Format present for UNFORMATTED data transfer");
2716 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2718 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2720 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2721 "A format cannot be specified with a namelist");
2725 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2726 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2728 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2729 "Missing format for FORMATTED data transfer");
2733 if (is_internal_unit (dtp
)
2734 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2736 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2737 "Internal file cannot be accessed by UNFORMATTED "
2742 /* Check the record or position number. */
2744 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2745 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2747 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2748 "Direct access data transfer requires record number");
2752 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2754 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2756 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2757 "Record number not allowed for sequential access "
2762 if (compile_options
.warn_std
&&
2763 dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
)
2765 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2766 "Sequential READ or WRITE not allowed after "
2767 "EOF marker, possibly use REWIND or BACKSPACE");
2771 /* Process the ADVANCE option. */
2773 dtp
->u
.p
.advance_status
2774 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2775 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2776 "Bad ADVANCE parameter in data transfer statement");
2778 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2780 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2782 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2783 "ADVANCE specification conflicts with sequential "
2788 if (is_internal_unit (dtp
))
2790 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2791 "ADVANCE specification conflicts with internal file");
2795 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2796 != IOPARM_DT_HAS_FORMAT
)
2798 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2799 "ADVANCE specification requires an explicit format");
2806 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2808 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2810 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2811 "EOR specification requires an ADVANCE specification "
2816 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2817 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2819 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2820 "SIZE specification requires an ADVANCE "
2821 "specification of NO");
2826 { /* Write constraints. */
2827 if ((cf
& IOPARM_END
) != 0)
2829 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2830 "END specification cannot appear in a write "
2835 if ((cf
& IOPARM_EOR
) != 0)
2837 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2838 "EOR specification cannot appear in a write "
2843 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2845 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2846 "SIZE specification cannot appear in a write "
2852 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2853 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2855 /* Check the decimal mode. */
2856 dtp
->u
.p
.current_unit
->decimal_status
2857 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2858 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2859 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2862 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2863 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2865 /* Check the round mode. */
2866 dtp
->u
.p
.current_unit
->round_status
2867 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
2868 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
2869 round_opt
, "Bad ROUND parameter in data transfer "
2872 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
2873 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
2875 /* Check the sign mode. */
2876 dtp
->u
.p
.sign_status
2877 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2878 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2879 "Bad SIGN parameter in data transfer statement");
2881 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2882 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2884 /* Check the blank mode. */
2885 dtp
->u
.p
.blank_status
2886 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2887 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2889 "Bad BLANK parameter in data transfer statement");
2891 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2892 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2894 /* Check the delim mode. */
2895 dtp
->u
.p
.current_unit
->delim_status
2896 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2897 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2898 delim_opt
, "Bad DELIM parameter in data transfer statement");
2900 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2902 if (ionml
&& dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_UNSPECIFIED
)
2903 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
2905 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2908 /* Check the pad mode. */
2909 dtp
->u
.p
.current_unit
->pad_status
2910 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2911 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2912 "Bad PAD parameter in data transfer statement");
2914 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2915 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2917 /* Check to see if we might be reading what we wrote before */
2919 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2920 && !is_internal_unit (dtp
))
2922 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2924 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2925 sflush(dtp
->u
.p
.current_unit
->s
);
2928 /* Check the POS= specifier: that it is in range and that it is used with a
2929 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2931 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2933 if (is_stream_io (dtp
))
2938 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2939 "POS=specifier must be positive");
2943 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2945 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2946 "POS=specifier too large");
2950 dtp
->rec
= dtp
->pos
;
2952 if (dtp
->u
.p
.mode
== READING
)
2954 /* Reset the endfile flag; if we hit EOF during reading
2955 we'll set the flag and generate an error at that point
2956 rather than worrying about it here. */
2957 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2960 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2962 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2963 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
2965 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2968 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2973 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2974 "POS=specifier not allowed, "
2975 "Try OPEN with ACCESS='stream'");
2981 /* Sanity checks on the record number. */
2982 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2986 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2987 "Record number must be positive");
2991 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2993 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2994 "Record number too large");
2998 /* Make sure format buffer is reset. */
2999 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3000 fbuf_reset (dtp
->u
.p
.current_unit
);
3003 /* Check whether the record exists to be read. Only
3004 a partial record needs to exist. */
3006 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
3007 * dtp
->u
.p
.current_unit
->recl
>= ssize (dtp
->u
.p
.current_unit
->s
))
3009 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3010 "Non-existing record number");
3014 /* Position the file. */
3015 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
3016 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
3018 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3022 /* TODO: This is required to maintain compatibility between
3023 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
3025 if (is_stream_io (dtp
))
3026 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
3028 /* TODO: Un-comment this code when ABI changes from 4.3.
3029 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
3031 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
3032 "Record number not allowed for stream access "
3038 /* Bugware for badly written mixed C-Fortran I/O. */
3039 if (!is_internal_unit (dtp
))
3040 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
3042 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
3044 /* Set the maximum position reached from the previous I/O operation. This
3045 could be greater than zero from a previous non-advancing write. */
3046 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
3051 /* Set up the subroutine that will handle the transfers. */
3055 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3056 dtp
->u
.p
.transfer
= unformatted_read
;
3059 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3061 if (dtp
->u
.p
.current_unit
->child_dtio
== 0)
3062 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
3063 dtp
->u
.p
.transfer
= list_formatted_read
;
3066 dtp
->u
.p
.transfer
= formatted_transfer
;
3071 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3072 dtp
->u
.p
.transfer
= unformatted_write
;
3075 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3076 dtp
->u
.p
.transfer
= list_formatted_write
;
3078 dtp
->u
.p
.transfer
= formatted_transfer
;
3082 /* Make sure that we don't do a read after a nonadvancing write. */
3086 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
3088 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3089 "Cannot READ after a nonadvancing WRITE");
3095 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
3096 dtp
->u
.p
.current_unit
->read_bad
= 1;
3099 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3101 #ifdef HAVE_USELOCALE
3102 dtp
->u
.p
.old_locale
= uselocale (c_locale
);
3104 __gthread_mutex_lock (&old_locale_lock
);
3105 if (!old_locale_ctr
++)
3107 old_locale
= setlocale (LC_NUMERIC
, NULL
);
3108 setlocale (LC_NUMERIC
, "C");
3110 __gthread_mutex_unlock (&old_locale_lock
);
3112 /* Start the data transfer if we are doing a formatted transfer. */
3113 if ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0
3114 && dtp
->u
.p
.ionml
== NULL
)
3115 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
3120 /* Initialize an array_loop_spec given the array descriptor. The function
3121 returns the index of the last element of the array, and also returns
3122 starting record, where the first I/O goes to (necessary in case of
3123 negative strides). */
3126 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
3127 gfc_offset
*start_record
)
3129 int rank
= GFC_DESCRIPTOR_RANK(desc
);
3138 for (i
=0; i
<rank
; i
++)
3140 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3141 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3142 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
3143 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
3144 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
3145 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
3147 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
3149 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3150 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3154 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3155 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3156 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3157 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3167 /* Determine the index to the next record in an internal unit array by
3168 by incrementing through the array_loop_spec. */
3171 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
3179 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
3184 if (ls
[i
].idx
> ls
[i
].end
)
3186 ls
[i
].idx
= ls
[i
].start
;
3192 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
3202 /* Skip to the end of the current record, taking care of an optional
3203 record marker of size bytes. If the file is not seekable, we
3204 read chunks of size MAX_READ until we get to the right
3208 skip_record (st_parameter_dt
*dtp
, ssize_t bytes
)
3210 ssize_t rlength
, readb
;
3211 #define MAX_READ 4096
3214 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
3215 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
3218 /* Direct access files do not generate END conditions,
3220 if (sseek (dtp
->u
.p
.current_unit
->s
,
3221 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
3223 /* Seeking failed, fall back to seeking by reading data. */
3224 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
3227 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
3228 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3230 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
3233 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3237 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
3241 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= 0;
3245 /* Advance to the next record reading unformatted files, taking
3246 care of subrecords. If complete_record is nonzero, we loop
3247 until all subrecords are cleared. */
3250 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
3254 bytes
= compile_options
.record_marker
== 0 ?
3255 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
3260 /* Skip over tail */
3262 skip_record (dtp
, bytes
);
3264 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
3273 min_off (gfc_offset a
, gfc_offset b
)
3275 return (a
< b
? a
: b
);
3279 /* Space to the next record for read mode. */
3282 next_record_r (st_parameter_dt
*dtp
, int done
)
3289 switch (current_mode (dtp
))
3291 /* No records in unformatted STREAM I/O. */
3292 case UNFORMATTED_STREAM
:
3295 case UNFORMATTED_SEQUENTIAL
:
3296 next_record_r_unf (dtp
, 1);
3297 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3300 case FORMATTED_DIRECT
:
3301 case UNFORMATTED_DIRECT
:
3302 skip_record (dtp
, dtp
->u
.p
.current_unit
->bytes_left
);
3305 case FORMATTED_STREAM
:
3306 case FORMATTED_SEQUENTIAL
:
3307 /* read_sf has already terminated input because of an '\n', or
3309 if (dtp
->u
.p
.sf_seen_eor
)
3311 dtp
->u
.p
.sf_seen_eor
= 0;
3315 if (is_internal_unit (dtp
))
3317 if (is_array_io (dtp
))
3321 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3323 if (!done
&& finished
)
3326 /* Now seek to this record. */
3327 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3328 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3330 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3333 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3337 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3338 bytes_left
= min_off (bytes_left
,
3339 ssize (dtp
->u
.p
.current_unit
->s
)
3340 - stell (dtp
->u
.p
.current_unit
->s
));
3341 if (sseek (dtp
->u
.p
.current_unit
->s
,
3342 bytes_left
, SEEK_CUR
) < 0)
3344 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3347 dtp
->u
.p
.current_unit
->bytes_left
3348 = dtp
->u
.p
.current_unit
->recl
;
3357 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
3361 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3364 if (is_stream_io (dtp
)
3365 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
3366 || dtp
->u
.p
.current_unit
->bytes_left
3367 == dtp
->u
.p
.current_unit
->recl
)
3373 if (is_stream_io (dtp
))
3374 dtp
->u
.p
.current_unit
->strm_pos
++;
3385 /* Small utility function to write a record marker, taking care of
3386 byte swapping and of choosing the correct size. */
3389 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
3395 if (compile_options
.record_marker
== 0)
3396 len
= sizeof (GFC_INTEGER_4
);
3398 len
= compile_options
.record_marker
;
3400 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
3401 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
3405 case sizeof (GFC_INTEGER_4
):
3407 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
3410 case sizeof (GFC_INTEGER_8
):
3412 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
3416 runtime_error ("Illegal value for record marker");
3426 case sizeof (GFC_INTEGER_4
):
3428 memcpy (&u32
, &buf4
, sizeof (u32
));
3429 u32
= __builtin_bswap32 (u32
);
3430 return swrite (dtp
->u
.p
.current_unit
->s
, &u32
, len
);
3433 case sizeof (GFC_INTEGER_8
):
3435 memcpy (&u64
, &buf8
, sizeof (u64
));
3436 u64
= __builtin_bswap64 (u64
);
3437 return swrite (dtp
->u
.p
.current_unit
->s
, &u64
, len
);
3441 runtime_error ("Illegal value for record marker");
3448 /* Position to the next (sub)record in write mode for
3449 unformatted sequential files. */
3452 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
3454 gfc_offset m
, m_write
, record_marker
;
3456 /* Bytes written. */
3457 m
= dtp
->u
.p
.current_unit
->recl_subrecord
3458 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3460 if (compile_options
.record_marker
== 0)
3461 record_marker
= sizeof (GFC_INTEGER_4
);
3463 record_marker
= compile_options
.record_marker
;
3465 /* Seek to the head and overwrite the bogus length with the real
3468 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- record_marker
,
3477 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3480 /* Seek past the end of the current record. */
3482 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
, SEEK_CUR
) < 0))
3485 /* Write the length tail. If we finish a record containing
3486 subrecords, we write out the negative length. */
3488 if (dtp
->u
.p
.current_unit
->continued
)
3493 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3499 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3505 /* Utility function like memset() but operating on streams. Return
3506 value is same as for POSIX write(). */
3509 sset (stream
* s
, int c
, ssize_t nbyte
)
3511 #define WRITE_CHUNK 256
3512 char p
[WRITE_CHUNK
];
3513 ssize_t bytes_left
, trans
;
3515 if (nbyte
< WRITE_CHUNK
)
3516 memset (p
, c
, nbyte
);
3518 memset (p
, c
, WRITE_CHUNK
);
3521 while (bytes_left
> 0)
3523 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
3524 trans
= swrite (s
, p
, trans
);
3527 bytes_left
-= trans
;
3530 return nbyte
- bytes_left
;
3534 /* Position to the next record in write mode. */
3537 next_record_w (st_parameter_dt
*dtp
, int done
)
3539 gfc_offset m
, record
, max_pos
;
3542 /* Zero counters for X- and T-editing. */
3543 max_pos
= dtp
->u
.p
.max_pos
;
3544 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
3546 switch (current_mode (dtp
))
3548 /* No records in unformatted STREAM I/O. */
3549 case UNFORMATTED_STREAM
:
3552 case FORMATTED_DIRECT
:
3553 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
3556 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3557 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
3558 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
3559 dtp
->u
.p
.current_unit
->bytes_left
)
3560 != dtp
->u
.p
.current_unit
->bytes_left
)
3565 case UNFORMATTED_DIRECT
:
3566 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
3568 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3569 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3574 case UNFORMATTED_SEQUENTIAL
:
3575 next_record_w_unf (dtp
, 0);
3576 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3579 case FORMATTED_STREAM
:
3580 case FORMATTED_SEQUENTIAL
:
3582 if (is_internal_unit (dtp
))
3585 if (is_array_io (dtp
))
3589 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3591 /* If the farthest position reached is greater than current
3592 position, adjust the position and set length to pad out
3593 whats left. Otherwise just pad whats left.
3594 (for character array unit) */
3595 m
= dtp
->u
.p
.current_unit
->recl
3596 - dtp
->u
.p
.current_unit
->bytes_left
;
3599 length
= (int) (max_pos
- m
);
3600 if (sseek (dtp
->u
.p
.current_unit
->s
,
3601 length
, SEEK_CUR
) < 0)
3603 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3606 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3609 p
= write_block (dtp
, length
);
3613 if (unlikely (is_char4_unit (dtp
)))
3615 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3616 memset4 (p4
, ' ', length
);
3619 memset (p
, ' ', length
);
3621 /* Now that the current record has been padded out,
3622 determine where the next record in the array is. */
3623 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3626 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3628 /* Now seek to this record */
3629 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3631 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3633 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3637 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3643 /* If this is the last call to next_record move to the farthest
3644 position reached and set length to pad out the remainder
3645 of the record. (for character scaler unit) */
3648 m
= dtp
->u
.p
.current_unit
->recl
3649 - dtp
->u
.p
.current_unit
->bytes_left
;
3652 length
= (int) (max_pos
- m
);
3653 if (sseek (dtp
->u
.p
.current_unit
->s
,
3654 length
, SEEK_CUR
) < 0)
3656 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3659 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3662 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3666 p
= write_block (dtp
, length
);
3670 if (unlikely (is_char4_unit (dtp
)))
3672 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3673 memset4 (p4
, (gfc_char4_t
) ' ', length
);
3676 memset (p
, ' ', length
);
3687 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3688 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3695 if (is_stream_io (dtp
))
3697 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3698 if (dtp
->u
.p
.current_unit
->strm_pos
3699 < ssize (dtp
->u
.p
.current_unit
->s
))
3700 unit_truncate (dtp
->u
.p
.current_unit
,
3701 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3709 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3714 /* Position to the next record, which means moving to the end of the
3715 current record. This can happen under several different
3716 conditions. If the done flag is not set, we get ready to process
3720 next_record (st_parameter_dt
*dtp
, int done
)
3722 gfc_offset fp
; /* File position. */
3724 dtp
->u
.p
.current_unit
->read_bad
= 0;
3726 if (dtp
->u
.p
.mode
== READING
)
3727 next_record_r (dtp
, done
);
3729 next_record_w (dtp
, done
);
3731 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3733 if (!is_stream_io (dtp
))
3735 /* Since we have changed the position, set it to unspecified so
3736 that INQUIRE(POSITION=) knows it needs to look into it. */
3738 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_UNSPECIFIED
;
3740 dtp
->u
.p
.current_unit
->current_record
= 0;
3741 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3743 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3744 /* Calculate next record, rounding up partial records. */
3745 dtp
->u
.p
.current_unit
->last_record
=
3746 (fp
+ dtp
->u
.p
.current_unit
->recl
) /
3747 dtp
->u
.p
.current_unit
->recl
- 1;
3750 dtp
->u
.p
.current_unit
->last_record
++;
3756 smarkeor (dtp
->u
.p
.current_unit
->s
);
3760 /* Finalize the current data transfer. For a nonadvancing transfer,
3761 this means advancing to the next record. For internal units close the
3762 stream associated with the unit. */
3765 finalize_transfer (st_parameter_dt
*dtp
)
3767 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3769 if ((dtp
->u
.p
.ionml
!= NULL
)
3770 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3772 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3773 namelist_read (dtp
);
3775 namelist_write (dtp
);
3778 if (dtp
->u
.p
.current_unit
&& (dtp
->u
.p
.current_unit
->child_dtio
> 0))
3781 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3782 *dtp
->size
= dtp
->u
.p
.size_used
;
3784 if (dtp
->u
.p
.eor_condition
)
3786 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3790 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3792 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3793 dtp
->u
.p
.current_unit
->current_record
= 0;
3797 dtp
->u
.p
.transfer
= NULL
;
3798 if (dtp
->u
.p
.current_unit
== NULL
)
3801 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3803 finish_list_read (dtp
);
3807 if (dtp
->u
.p
.mode
== WRITING
)
3808 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3809 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3811 if (is_stream_io (dtp
))
3813 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3814 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3815 next_record (dtp
, 1);
3820 dtp
->u
.p
.current_unit
->current_record
= 0;
3822 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3824 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3825 dtp
->u
.p
.seen_dollar
= 0;
3829 /* For non-advancing I/O, save the current maximum position for use in the
3830 next I/O operation if needed. */
3831 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3833 if (dtp
->u
.p
.skips
> 0)
3836 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
3837 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
3838 - dtp
->u
.p
.current_unit
->bytes_left
);
3840 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
3843 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3844 - dtp
->u
.p
.current_unit
->bytes_left
);
3845 dtp
->u
.p
.current_unit
->saved_pos
=
3846 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3847 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3850 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3851 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3852 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3854 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3856 next_record (dtp
, 1);
3859 #ifdef HAVE_USELOCALE
3860 if (dtp
->u
.p
.old_locale
!= (locale_t
) 0)
3862 uselocale (dtp
->u
.p
.old_locale
);
3863 dtp
->u
.p
.old_locale
= (locale_t
) 0;
3866 __gthread_mutex_lock (&old_locale_lock
);
3867 if (!--old_locale_ctr
)
3869 setlocale (LC_NUMERIC
, old_locale
);
3872 __gthread_mutex_unlock (&old_locale_lock
);
3876 /* Transfer function for IOLENGTH. It doesn't actually do any
3877 data transfer, it just updates the length counter. */
3880 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3881 void *dest
__attribute__ ((unused
)),
3882 int kind
__attribute__((unused
)),
3883 size_t size
, size_t nelems
)
3885 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3886 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3890 /* Initialize the IOLENGTH data transfer. This function is in essence
3891 a very much simplified version of data_transfer_init(), because it
3892 doesn't have to deal with units at all. */
3895 iolength_transfer_init (st_parameter_dt
*dtp
)
3897 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3900 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3902 /* Set up the subroutine that will handle the transfers. */
3904 dtp
->u
.p
.transfer
= iolength_transfer
;
3908 /* Library entry point for the IOLENGTH form of the INQUIRE
3909 statement. The IOLENGTH form requires no I/O to be performed, but
3910 it must still be a runtime library call so that we can determine
3911 the iolength for dynamic arrays and such. */
3913 extern void st_iolength (st_parameter_dt
*);
3914 export_proto(st_iolength
);
3917 st_iolength (st_parameter_dt
*dtp
)
3919 library_start (&dtp
->common
);
3920 iolength_transfer_init (dtp
);
3923 extern void st_iolength_done (st_parameter_dt
*);
3924 export_proto(st_iolength_done
);
3927 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3934 /* The READ statement. */
3936 extern void st_read (st_parameter_dt
*);
3937 export_proto(st_read
);
3940 st_read (st_parameter_dt
*dtp
)
3942 library_start (&dtp
->common
);
3944 data_transfer_init (dtp
, 1);
3947 extern void st_read_done (st_parameter_dt
*);
3948 export_proto(st_read_done
);
3951 st_read_done (st_parameter_dt
*dtp
)
3953 finalize_transfer (dtp
);
3957 /* If this is a parent READ statement we do not need to retain the
3958 internal unit structure for child use. Free it and stash the unit
3959 number for reuse. */
3960 if (dtp
->u
.p
.current_unit
!= NULL
3961 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
3963 if (is_internal_unit (dtp
) &&
3964 (dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
3966 free (dtp
->u
.p
.current_unit
->filename
);
3967 dtp
->u
.p
.current_unit
->filename
= NULL
;
3968 free_format_hash_table (dtp
->u
.p
.current_unit
);
3969 free (dtp
->u
.p
.current_unit
->s
);
3970 dtp
->u
.p
.current_unit
->s
= NULL
;
3971 if (dtp
->u
.p
.current_unit
->ls
)
3972 free (dtp
->u
.p
.current_unit
->ls
);
3973 dtp
->u
.p
.current_unit
->ls
= NULL
;
3974 stash_internal_unit (dtp
);
3976 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3978 free_format_data (dtp
->u
.p
.fmt
);
3981 unlock_unit (dtp
->u
.p
.current_unit
);
3987 extern void st_write (st_parameter_dt
*);
3988 export_proto(st_write
);
3991 st_write (st_parameter_dt
*dtp
)
3993 library_start (&dtp
->common
);
3994 data_transfer_init (dtp
, 0);
3997 extern void st_write_done (st_parameter_dt
*);
3998 export_proto(st_write_done
);
4001 st_write_done (st_parameter_dt
*dtp
)
4003 finalize_transfer (dtp
);
4005 if (dtp
->u
.p
.current_unit
!= NULL
4006 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4008 /* Deal with endfile conditions associated with sequential files. */
4009 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4010 switch (dtp
->u
.p
.current_unit
->endfile
)
4012 case AT_ENDFILE
: /* Remain at the endfile record. */
4016 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
4020 /* Get rid of whatever is after this record. */
4021 if (!is_internal_unit (dtp
))
4022 unit_truncate (dtp
->u
.p
.current_unit
,
4023 stell (dtp
->u
.p
.current_unit
->s
),
4025 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4031 /* If this is a parent WRITE statement we do not need to retain the
4032 internal unit structure for child use. Free it and stash the
4033 unit number for reuse. */
4034 if (is_internal_unit (dtp
) &&
4035 (dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4037 free (dtp
->u
.p
.current_unit
->filename
);
4038 dtp
->u
.p
.current_unit
->filename
= NULL
;
4039 free_format_hash_table (dtp
->u
.p
.current_unit
);
4040 free (dtp
->u
.p
.current_unit
->s
);
4041 dtp
->u
.p
.current_unit
->s
= NULL
;
4042 if (dtp
->u
.p
.current_unit
->ls
)
4043 free (dtp
->u
.p
.current_unit
->ls
);
4044 dtp
->u
.p
.current_unit
->ls
= NULL
;
4045 stash_internal_unit (dtp
);
4047 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
4049 free_format_data (dtp
->u
.p
.fmt
);
4052 unlock_unit (dtp
->u
.p
.current_unit
);
4058 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
4060 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
4065 /* Receives the scalar information for namelist objects and stores it
4066 in a linked list of namelist_info types. */
4069 set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4070 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4071 GFC_INTEGER_4 dtype
, void *dtio_sub
, void *vtable
)
4073 namelist_info
*t1
= NULL
;
4075 size_t var_name_len
= strlen (var_name
);
4077 nml
= (namelist_info
*) xmalloc (sizeof (namelist_info
));
4079 nml
->mem_pos
= var_addr
;
4080 nml
->dtio_sub
= dtio_sub
;
4081 nml
->vtable
= vtable
;
4083 nml
->var_name
= (char*) xmalloc (var_name_len
+ 1);
4084 memcpy (nml
->var_name
, var_name
, var_name_len
);
4085 nml
->var_name
[var_name_len
] = '\0';
4087 nml
->len
= (int) len
;
4088 nml
->string_length
= (index_type
) string_length
;
4090 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
4091 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
4092 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
4094 if (nml
->var_rank
> 0)
4096 nml
->dim
= (descriptor_dimension
*)
4097 xmallocarray (nml
->var_rank
, sizeof (descriptor_dimension
));
4098 nml
->ls
= (array_loop_spec
*)
4099 xmallocarray (nml
->var_rank
, sizeof (array_loop_spec
));
4109 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
4111 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
4112 dtp
->u
.p
.ionml
= nml
;
4116 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
4121 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
4122 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
4123 export_proto(st_set_nml_var
);
4126 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4127 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4128 GFC_INTEGER_4 dtype
)
4130 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4135 /* Essentially the same as previous but carrying the dtio procedure
4136 and the vtable as additional arguments. */
4137 extern void st_set_nml_dtio_var (st_parameter_dt
*dtp
, void *, char *,
4138 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
,
4140 export_proto(st_set_nml_dtio_var
);
4144 st_set_nml_dtio_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4145 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4146 GFC_INTEGER_4 dtype
, void *dtio_sub
, void *vtable
)
4148 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4149 dtype
, dtio_sub
, vtable
);
4152 /* Store the dimensional information for the namelist object. */
4153 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
4154 index_type
, index_type
,
4156 export_proto(st_set_nml_var_dim
);
4159 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
4160 index_type stride
, index_type lbound
,
4163 namelist_info
* nml
;
4168 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
4170 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
4174 /* Once upon a time, a poor innocent Fortran program was reading a
4175 file, when suddenly it hit the end-of-file (EOF). Unfortunately
4176 the OS doesn't tell whether we're at the EOF or whether we already
4177 went past it. Luckily our hero, libgfortran, keeps track of this.
4178 Call this function when you detect an EOF condition. See Section
4182 hit_eof (st_parameter_dt
* dtp
)
4184 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
4186 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4187 switch (dtp
->u
.p
.current_unit
->endfile
)
4191 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4192 if (!is_internal_unit (dtp
) && !dtp
->u
.p
.namelist_mode
)
4194 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
4195 dtp
->u
.p
.current_unit
->current_record
= 0;
4198 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4202 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
4203 dtp
->u
.p
.current_unit
->current_record
= 0;
4208 /* Non-sequential files don't have an ENDFILE record, so we
4209 can't be at AFTER_ENDFILE. */
4210 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4211 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4212 dtp
->u
.p
.current_unit
->current_record
= 0;