1 /* Copyright (C) 2002-2015 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 static void us_read (st_parameter_dt
*, int);
126 static void us_write (st_parameter_dt
*, int);
127 static void next_record_r_unf (st_parameter_dt
*, int);
128 static void next_record_w_unf (st_parameter_dt
*, int);
130 static const st_option advance_opt
[] = {
131 {"yes", ADVANCE_YES
},
137 static const st_option decimal_opt
[] = {
138 {"point", DECIMAL_POINT
},
139 {"comma", DECIMAL_COMMA
},
143 static const st_option round_opt
[] = {
145 {"down", ROUND_DOWN
},
146 {"zero", ROUND_ZERO
},
147 {"nearest", ROUND_NEAREST
},
148 {"compatible", ROUND_COMPATIBLE
},
149 {"processor_defined", ROUND_PROCDEFINED
},
154 static const st_option sign_opt
[] = {
156 {"suppress", SIGN_SS
},
157 {"processor_defined", SIGN_S
},
161 static const st_option blank_opt
[] = {
162 {"null", BLANK_NULL
},
163 {"zero", BLANK_ZERO
},
167 static const st_option delim_opt
[] = {
168 {"apostrophe", DELIM_APOSTROPHE
},
169 {"quote", DELIM_QUOTE
},
170 {"none", DELIM_NONE
},
174 static const st_option pad_opt
[] = {
181 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
182 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
188 current_mode (st_parameter_dt
*dtp
)
192 m
= FORM_UNSPECIFIED
;
194 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
196 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
197 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
199 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
201 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
202 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
204 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
206 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
207 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
214 /* Mid level data transfer statements. */
216 /* Read sequential file - internal unit */
219 read_sf_internal (st_parameter_dt
*dtp
, int * length
)
221 static char *empty_string
[0];
225 /* Zero size array gives internal unit len of 0. Nothing to read. */
226 if (dtp
->internal_unit_len
== 0
227 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
230 /* If we have seen an eor previously, return a length of 0. The
231 caller is responsible for correctly padding the input field. */
232 if (dtp
->u
.p
.sf_seen_eor
)
235 /* Just return something that isn't a NULL pointer, otherwise the
236 caller thinks an error occurred. */
237 return (char*) empty_string
;
241 if (is_char4_unit(dtp
))
244 gfc_char4_t
*p
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
,
246 base
= fbuf_alloc (dtp
->u
.p
.current_unit
, lorig
);
247 for (i
= 0; i
< *length
; i
++, p
++)
248 base
[i
] = *p
> 255 ? '?' : (unsigned char) *p
;
251 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
253 if (unlikely (lorig
> *length
))
259 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
261 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
262 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *length
;
268 /* When reading sequential formatted records we have a problem. We
269 don't know how long the line is until we read the trailing newline,
270 and we don't want to read too much. If we read too much, we might
271 have to do a physical seek backwards depending on how much data is
272 present, and devices like terminals aren't seekable and would cause
275 Given this, the solution is to read a byte at a time, stopping if
276 we hit the newline. For small allocations, we use a static buffer.
277 For larger allocations, we are forced to allocate memory on the
278 heap. Hopefully this won't happen very often. */
280 /* Read sequential file - external unit */
283 read_sf (st_parameter_dt
*dtp
, int * length
)
285 static char *empty_string
[0];
287 int n
, lorig
, seen_comma
;
289 /* If we have seen an eor previously, return a length of 0. The
290 caller is responsible for correctly padding the input field. */
291 if (dtp
->u
.p
.sf_seen_eor
)
294 /* Just return something that isn't a NULL pointer, otherwise the
295 caller thinks an error occurred. */
296 return (char*) empty_string
;
301 /* Read data into format buffer and scan through it. */
306 q
= fbuf_getc (dtp
->u
.p
.current_unit
);
309 else if (q
== '\n' || q
== '\r')
311 /* Unexpected end of line. Set the position. */
312 dtp
->u
.p
.sf_seen_eor
= 1;
314 /* If we see an EOR during non-advancing I/O, we need to skip
315 the rest of the I/O statement. Set the corresponding flag. */
316 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
317 dtp
->u
.p
.eor_condition
= 1;
319 /* If we encounter a CR, it might be a CRLF. */
320 if (q
== '\r') /* Probably a CRLF */
322 /* See if there is an LF. */
323 q2
= fbuf_getc (dtp
->u
.p
.current_unit
);
325 dtp
->u
.p
.sf_seen_eor
= 2;
326 else if (q2
!= EOF
) /* Oops, seek back. */
327 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
330 /* Without padding, terminate the I/O statement without assigning
331 the value. With padding, the value still needs to be assigned,
332 so we can just continue with a short read. */
333 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
335 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
342 /* Short circuit the read if a comma is found during numeric input.
343 The flag is set to zero during character reads so that commas in
344 strings are not ignored */
346 if (dtp
->u
.p
.sf_read_comma
== 1)
349 notify_std (&dtp
->common
, GFC_STD_GNU
,
350 "Comma in formatted numeric read.");
358 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
359 some other stuff. Set the relevant flags. */
360 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
364 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
366 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
372 dtp
->u
.p
.eor_condition
= 1;
377 else if (dtp
->u
.p
.advance_status
== ADVANCE_NO
378 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
379 || dtp
->u
.p
.current_unit
->bytes_left
380 == dtp
->u
.p
.current_unit
->recl
)
389 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
391 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
392 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) n
;
394 /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
395 fbuf_getc might reallocate the buffer. So return current pointer
396 minus all the advances, which is n plus up to two characters
397 of newline or comma. */
398 return fbuf_getptr (dtp
->u
.p
.current_unit
)
399 - n
- dtp
->u
.p
.sf_seen_eor
- seen_comma
;
403 /* Function for reading the next couple of bytes from the current
404 file, advancing the current position. We return NULL on end of record or
405 end of file. This function is only for formatted I/O, unformatted uses
408 If the read is short, then it is because the current record does not
409 have enough data to satisfy the read request and the file was
410 opened with PAD=YES. The caller must assume tailing spaces for
414 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
419 if (!is_stream_io (dtp
))
421 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
423 /* For preconnected units with default record length, set bytes left
424 to unit record length and proceed, otherwise error. */
425 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
426 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
427 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
430 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
431 && !is_internal_unit (dtp
))
433 /* Not enough data left. */
434 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
439 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0
440 && !is_internal_unit(dtp
)))
446 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
450 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
451 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
452 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
454 if (is_internal_unit (dtp
))
455 source
= read_sf_internal (dtp
, nbytes
);
457 source
= read_sf (dtp
, nbytes
);
459 dtp
->u
.p
.current_unit
->strm_pos
+=
460 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
464 /* If we reach here, we can assume it's direct access. */
466 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
469 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
470 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
472 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
473 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *nbytes
;
475 if (norig
!= *nbytes
)
477 /* Short read, this shouldn't happen. */
478 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
480 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
485 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
491 /* Read a block from a character(kind=4) internal unit, to be transferred into
492 a character(kind=4) variable. Note: Portions of this code borrowed from
495 read_block_form4 (st_parameter_dt
*dtp
, int * nbytes
)
497 static gfc_char4_t
*empty_string
[0];
501 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
502 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
504 /* Zero size array gives internal unit len of 0. Nothing to read. */
505 if (dtp
->internal_unit_len
== 0
506 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
509 /* If we have seen an eor previously, return a length of 0. The
510 caller is responsible for correctly padding the input field. */
511 if (dtp
->u
.p
.sf_seen_eor
)
514 /* Just return something that isn't a NULL pointer, otherwise the
515 caller thinks an error occurred. */
520 source
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
, nbytes
);
522 if (unlikely (lorig
> *nbytes
))
528 dtp
->u
.p
.current_unit
->bytes_left
-= *nbytes
;
530 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
531 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *nbytes
;
537 /* Reads a block directly into application data space. This is for
538 unformatted files. */
541 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
543 ssize_t to_read_record
;
544 ssize_t have_read_record
;
545 ssize_t to_read_subrecord
;
546 ssize_t have_read_subrecord
;
549 if (is_stream_io (dtp
))
551 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
553 if (unlikely (have_read_record
< 0))
555 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
559 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
561 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
563 /* Short read, e.g. if we hit EOF. For stream files,
564 we have to set the end-of-file condition. */
570 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
572 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
575 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
576 nbytes
= to_read_record
;
581 to_read_record
= nbytes
;
584 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
586 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
587 if (unlikely (to_read_record
< 0))
589 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
593 if (to_read_record
!= (ssize_t
) nbytes
)
595 /* Short read, e.g. if we hit EOF. Apparently, we read
596 more than was written to the last record. */
600 if (unlikely (short_record
))
602 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
607 /* Unformatted sequential. We loop over the subrecords, reading
608 until the request has been fulfilled or the record has run out
609 of continuation subrecords. */
611 /* Check whether we exceed the total record length. */
613 if (dtp
->u
.p
.current_unit
->flags
.has_recl
614 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
616 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
621 to_read_record
= nbytes
;
624 have_read_record
= 0;
628 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
629 < (gfc_offset
) to_read_record
)
631 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
632 to_read_record
-= to_read_subrecord
;
636 to_read_subrecord
= to_read_record
;
640 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
642 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
643 buf
+ have_read_record
, to_read_subrecord
);
644 if (unlikely (have_read_subrecord
< 0))
646 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
650 have_read_record
+= have_read_subrecord
;
652 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
654 /* Short read, e.g. if we hit EOF. This means the record
655 structure has been corrupted, or the trailing record
656 marker would still be present. */
658 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
662 if (to_read_record
> 0)
664 if (likely (dtp
->u
.p
.current_unit
->continued
))
666 next_record_r_unf (dtp
, 0);
671 /* Let's make sure the file position is correctly pre-positioned
672 for the next read statement. */
674 dtp
->u
.p
.current_unit
->current_record
= 0;
675 next_record_r_unf (dtp
, 0);
676 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
682 /* Normal exit, the read request has been fulfilled. */
687 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
688 if (unlikely (short_record
))
690 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
697 /* Function for writing a block of bytes to the current file at the
698 current position, advancing the file pointer. We are given a length
699 and return a pointer to a buffer that the caller must (completely)
700 fill in. Returns NULL on error. */
703 write_block (st_parameter_dt
*dtp
, int length
)
707 if (!is_stream_io (dtp
))
709 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
711 /* For preconnected units with default record length, set bytes left
712 to unit record length and proceed, otherwise error. */
713 if (likely ((dtp
->u
.p
.current_unit
->unit_number
714 == options
.stdout_unit
715 || dtp
->u
.p
.current_unit
->unit_number
716 == options
.stderr_unit
)
717 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
718 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
721 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
726 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
729 if (is_internal_unit (dtp
))
731 if (dtp
->common
.unit
) /* char4 internel unit. */
734 dest4
= mem_alloc_w4 (dtp
->u
.p
.current_unit
->s
, &length
);
737 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
743 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
747 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
751 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
752 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
756 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
759 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
764 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
765 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) length
;
767 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
773 /* High level interface to swrite(), taking care of errors. This is only
774 called for unformatted files. There are three cases to consider:
775 Stream I/O, unformatted direct, unformatted sequential. */
778 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
781 ssize_t have_written
;
782 ssize_t to_write_subrecord
;
787 if (is_stream_io (dtp
))
789 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
790 if (unlikely (have_written
< 0))
792 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
796 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
801 /* Unformatted direct access. */
803 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
805 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
807 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
811 if (buf
== NULL
&& nbytes
== 0)
814 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
815 if (unlikely (have_written
< 0))
817 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
821 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
822 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
827 /* Unformatted sequential. */
831 if (dtp
->u
.p
.current_unit
->flags
.has_recl
832 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
834 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
846 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
847 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
849 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
850 (gfc_offset
) to_write_subrecord
;
852 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
853 buf
+ have_written
, to_write_subrecord
);
854 if (unlikely (to_write_subrecord
< 0))
856 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
860 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
861 nbytes
-= to_write_subrecord
;
862 have_written
+= to_write_subrecord
;
867 next_record_w_unf (dtp
, 1);
870 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
871 if (unlikely (short_record
))
873 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
880 /* Reverse memcpy - used for byte swapping. */
883 reverse_memcpy (void *dest
, const void *src
, size_t n
)
889 s
= (char *) src
+ n
- 1;
891 /* Write with ascending order - this is likely faster
892 on modern architectures because of write combining. */
898 /* Utility function for byteswapping an array, using the bswap
899 builtins if possible. dest and src can overlap completely, or then
900 they must point to separate objects; partial overlaps are not
904 bswap_array (void *dest
, const void *src
, size_t size
, size_t nelems
)
914 for (size_t i
= 0; i
< nelems
; i
++)
915 ((uint16_t*)dest
)[i
] = __builtin_bswap16 (((uint16_t*)src
)[i
]);
918 for (size_t i
= 0; i
< nelems
; i
++)
919 ((uint32_t*)dest
)[i
] = __builtin_bswap32 (((uint32_t*)src
)[i
]);
922 for (size_t i
= 0; i
< nelems
; i
++)
923 ((uint64_t*)dest
)[i
] = __builtin_bswap64 (((uint64_t*)src
)[i
]);
928 for (size_t i
= 0; i
< nelems
; i
++)
931 memcpy (&tmp
, ps
, 4);
932 *(uint32_t*)pd
= __builtin_bswap32 (*(uint32_t*)(ps
+ 8));
933 *(uint32_t*)(pd
+ 4) = __builtin_bswap32 (*(uint32_t*)(ps
+ 4));
934 *(uint32_t*)(pd
+ 8) = __builtin_bswap32 (tmp
);
942 for (size_t i
= 0; i
< nelems
; i
++)
945 memcpy (&tmp
, ps
, 8);
946 *(uint64_t*)pd
= __builtin_bswap64 (*(uint64_t*)(ps
+ 8));
947 *(uint64_t*)(pd
+ 8) = __builtin_bswap64 (tmp
);
957 for (size_t i
= 0; i
< nelems
; i
++)
959 reverse_memcpy (pd
, ps
, size
);
966 /* In-place byte swap. */
967 for (size_t i
= 0; i
< nelems
; i
++)
969 char tmp
, *low
= pd
, *high
= pd
+ size
- 1;
970 for (size_t j
= 0; j
< size
/2; j
++)
985 /* Master function for unformatted reads. */
988 unformatted_read (st_parameter_dt
*dtp
, bt type
,
989 void *dest
, int kind
, size_t size
, size_t nelems
)
991 if (type
== BT_CHARACTER
)
992 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
993 read_block_direct (dtp
, dest
, size
* nelems
);
995 if (unlikely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_SWAP
)
998 /* Handle wide chracters. */
999 if (type
== BT_CHARACTER
)
1005 /* Break up complex into its constituent reals. */
1006 else if (type
== BT_COMPLEX
)
1011 bswap_array (dest
, dest
, size
, nelems
);
1016 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
1017 bytes on 64 bit machines. The unused bytes are not initialized and never
1018 used, which can show an error with memory checking analyzers like
1022 unformatted_write (st_parameter_dt
*dtp
, bt type
,
1023 void *source
, int kind
, size_t size
, size_t nelems
)
1025 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1028 size_t stride
= type
== BT_CHARACTER
?
1029 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1031 write_buf (dtp
, source
, stride
* nelems
);
1035 #define BSWAP_BUFSZ 512
1036 char buffer
[BSWAP_BUFSZ
];
1042 /* Handle wide chracters. */
1043 if (type
== BT_CHARACTER
&& kind
!= 1)
1049 /* Break up complex into its constituent reals. */
1050 if (type
== BT_COMPLEX
)
1056 /* By now, all complex variables have been split into their
1057 constituent reals. */
1063 if (size
* nrem
> BSWAP_BUFSZ
)
1064 nc
= BSWAP_BUFSZ
/ size
;
1068 bswap_array (buffer
, p
, size
, nc
);
1069 write_buf (dtp
, buffer
, size
* nc
);
1078 /* Return a pointer to the name of a type. */
1103 internal_error (NULL
, "type_name(): Bad type");
1110 /* Write a constant string to the output.
1111 This is complicated because the string can have doubled delimiters
1112 in it. The length in the format node is the true length. */
1115 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
1117 char c
, delimiter
, *p
, *q
;
1120 length
= f
->u
.string
.length
;
1124 p
= write_block (dtp
, length
);
1131 for (; length
> 0; length
--)
1134 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
1135 q
++; /* Skip the doubled delimiter. */
1140 /* Given actual and expected types in a formatted data transfer, make
1141 sure they agree. If not, an error message is generated. Returns
1142 nonzero if something went wrong. */
1145 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
1148 char buffer
[BUFLEN
];
1150 if (actual
== expected
)
1153 /* Adjust item_count before emitting error message. */
1154 snprintf (buffer
, BUFLEN
,
1155 "Expected %s for item %d in formatted transfer, got %s",
1156 type_name (expected
), dtp
->u
.p
.item_count
- 1, type_name (actual
));
1158 format_error (dtp
, f
, buffer
);
1164 require_numeric_type (st_parameter_dt
*dtp
, bt actual
, const fnode
*f
)
1167 char buffer
[BUFLEN
];
1169 if (actual
== BT_INTEGER
|| actual
== BT_REAL
|| actual
== BT_COMPLEX
)
1172 /* Adjust item_count before emitting error message. */
1173 snprintf (buffer
, BUFLEN
,
1174 "Expected numeric type for item %d in formatted transfer, got %s",
1175 dtp
->u
.p
.item_count
- 1, type_name (actual
));
1177 format_error (dtp
, f
, buffer
);
1182 /* This function is in the main loop for a formatted data transfer
1183 statement. It would be natural to implement this as a coroutine
1184 with the user program, but C makes that awkward. We loop,
1185 processing format elements. When we actually have to transfer
1186 data instead of just setting flags, we return control to the user
1187 program which calls a function that supplies the address and type
1188 of the next element, then comes back here to process it. */
1191 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1194 int pos
, bytes_used
;
1198 int consume_data_flag
;
1200 /* Change a complex data item into a pair of reals. */
1202 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1203 if (type
== BT_COMPLEX
)
1209 /* If there's an EOR condition, we simulate finalizing the transfer
1210 by doing nothing. */
1211 if (dtp
->u
.p
.eor_condition
)
1214 /* Set this flag so that commas in reads cause the read to complete before
1215 the entire field has been read. The next read field will start right after
1216 the comma in the stream. (Set to 0 for character reads). */
1217 dtp
->u
.p
.sf_read_comma
=
1218 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1222 /* If reversion has occurred and there is another real data item,
1223 then we have to move to the next record. */
1224 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1226 dtp
->u
.p
.reversion_flag
= 0;
1227 next_record (dtp
, 0);
1230 consume_data_flag
= 1;
1231 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1234 f
= next_format (dtp
);
1237 /* No data descriptors left. */
1238 if (unlikely (n
> 0))
1239 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1240 "Insufficient data descriptors in format after reversion");
1246 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1247 - dtp
->u
.p
.current_unit
->bytes_left
);
1249 if (is_stream_io(dtp
))
1256 goto need_read_data
;
1257 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1259 read_decimal (dtp
, f
, p
, kind
);
1264 goto need_read_data
;
1265 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1266 && require_numeric_type (dtp
, type
, f
))
1268 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1269 && require_type (dtp
, BT_INTEGER
, type
, f
))
1271 read_radix (dtp
, f
, p
, kind
, 2);
1276 goto need_read_data
;
1277 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1278 && require_numeric_type (dtp
, type
, f
))
1280 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1281 && require_type (dtp
, BT_INTEGER
, type
, f
))
1283 read_radix (dtp
, f
, p
, kind
, 8);
1288 goto need_read_data
;
1289 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1290 && require_numeric_type (dtp
, type
, f
))
1292 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1293 && require_type (dtp
, BT_INTEGER
, type
, f
))
1295 read_radix (dtp
, f
, p
, kind
, 16);
1300 goto need_read_data
;
1302 /* It is possible to have FMT_A with something not BT_CHARACTER such
1303 as when writing out hollerith strings, so check both type
1304 and kind before calling wide character routines. */
1305 if (type
== BT_CHARACTER
&& kind
== 4)
1306 read_a_char4 (dtp
, f
, p
, size
);
1308 read_a (dtp
, f
, p
, size
);
1313 goto need_read_data
;
1314 read_l (dtp
, f
, p
, kind
);
1319 goto need_read_data
;
1320 if (require_type (dtp
, BT_REAL
, type
, f
))
1322 read_f (dtp
, f
, p
, kind
);
1327 goto need_read_data
;
1328 if (require_type (dtp
, BT_REAL
, type
, f
))
1330 read_f (dtp
, f
, p
, kind
);
1335 goto need_read_data
;
1336 if (require_type (dtp
, BT_REAL
, type
, f
))
1338 read_f (dtp
, f
, p
, kind
);
1343 goto need_read_data
;
1344 if (require_type (dtp
, BT_REAL
, type
, f
))
1346 read_f (dtp
, f
, p
, kind
);
1351 goto need_read_data
;
1352 if (require_type (dtp
, BT_REAL
, type
, f
))
1354 read_f (dtp
, f
, p
, kind
);
1359 goto need_read_data
;
1363 read_decimal (dtp
, f
, p
, kind
);
1366 read_l (dtp
, f
, p
, kind
);
1370 read_a_char4 (dtp
, f
, p
, size
);
1372 read_a (dtp
, f
, p
, size
);
1375 read_f (dtp
, f
, p
, kind
);
1378 internal_error (&dtp
->common
, "formatted_transfer(): Bad type");
1383 consume_data_flag
= 0;
1384 format_error (dtp
, f
, "Constant string in input format");
1387 /* Format codes that don't transfer data. */
1390 consume_data_flag
= 0;
1391 dtp
->u
.p
.skips
+= f
->u
.n
;
1392 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1393 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1394 read_x (dtp
, f
->u
.n
);
1399 consume_data_flag
= 0;
1401 if (f
->format
== FMT_TL
)
1403 /* Handle the special case when no bytes have been used yet.
1404 Cannot go below zero. */
1405 if (bytes_used
== 0)
1407 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1408 dtp
->u
.p
.skips
-= f
->u
.n
;
1409 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1412 pos
= bytes_used
- f
->u
.n
;
1417 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1418 left tab limit. We do not check if the position has gone
1419 beyond the end of record because a subsequent tab could
1420 bring us back again. */
1421 pos
= pos
< 0 ? 0 : pos
;
1423 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1424 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1425 + pos
- dtp
->u
.p
.max_pos
;
1426 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1427 ? 0 : dtp
->u
.p
.pending_spaces
;
1428 if (dtp
->u
.p
.skips
== 0)
1431 /* Adjust everything for end-of-record condition */
1432 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1434 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1435 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1437 dtp
->u
.p
.sf_seen_eor
= 0;
1439 if (dtp
->u
.p
.skips
< 0)
1441 if (is_internal_unit (dtp
))
1442 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1444 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1445 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1446 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1449 read_x (dtp
, dtp
->u
.p
.skips
);
1453 consume_data_flag
= 0;
1454 dtp
->u
.p
.sign_status
= SIGN_S
;
1458 consume_data_flag
= 0;
1459 dtp
->u
.p
.sign_status
= SIGN_SS
;
1463 consume_data_flag
= 0;
1464 dtp
->u
.p
.sign_status
= SIGN_SP
;
1468 consume_data_flag
= 0 ;
1469 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1473 consume_data_flag
= 0;
1474 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1478 consume_data_flag
= 0;
1479 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1483 consume_data_flag
= 0;
1484 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1488 consume_data_flag
= 0;
1489 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1493 consume_data_flag
= 0;
1494 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1498 consume_data_flag
= 0;
1499 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1503 consume_data_flag
= 0;
1504 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1508 consume_data_flag
= 0;
1509 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1513 consume_data_flag
= 0;
1514 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1518 consume_data_flag
= 0;
1519 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1523 consume_data_flag
= 0;
1524 dtp
->u
.p
.seen_dollar
= 1;
1528 consume_data_flag
= 0;
1529 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1530 next_record (dtp
, 0);
1534 /* A colon descriptor causes us to exit this loop (in
1535 particular preventing another / descriptor from being
1536 processed) unless there is another data item to be
1538 consume_data_flag
= 0;
1544 internal_error (&dtp
->common
, "Bad format node");
1547 /* Adjust the item count and data pointer. */
1549 if ((consume_data_flag
> 0) && (n
> 0))
1552 p
= ((char *) p
) + size
;
1557 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1558 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1563 /* Come here when we need a data descriptor but don't have one. We
1564 push the current format node back onto the input, then return and
1565 let the user program call us back with the data. */
1567 unget_format (dtp
, f
);
1572 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1575 int pos
, bytes_used
;
1579 int consume_data_flag
;
1581 /* Change a complex data item into a pair of reals. */
1583 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1584 if (type
== BT_COMPLEX
)
1590 /* If there's an EOR condition, we simulate finalizing the transfer
1591 by doing nothing. */
1592 if (dtp
->u
.p
.eor_condition
)
1595 /* Set this flag so that commas in reads cause the read to complete before
1596 the entire field has been read. The next read field will start right after
1597 the comma in the stream. (Set to 0 for character reads). */
1598 dtp
->u
.p
.sf_read_comma
=
1599 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1603 /* If reversion has occurred and there is another real data item,
1604 then we have to move to the next record. */
1605 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1607 dtp
->u
.p
.reversion_flag
= 0;
1608 next_record (dtp
, 0);
1611 consume_data_flag
= 1;
1612 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1615 f
= next_format (dtp
);
1618 /* No data descriptors left. */
1619 if (unlikely (n
> 0))
1620 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1621 "Insufficient data descriptors in format after reversion");
1625 /* Now discharge T, TR and X movements to the right. This is delayed
1626 until a data producing format to suppress trailing spaces. */
1629 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1630 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1631 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1632 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1633 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
1634 || t
== FMT_STRING
))
1636 if (dtp
->u
.p
.skips
> 0)
1639 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1640 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1641 - dtp
->u
.p
.current_unit
->bytes_left
);
1643 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1645 if (dtp
->u
.p
.skips
< 0)
1647 if (is_internal_unit (dtp
))
1648 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1650 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1651 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1653 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1656 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1657 - dtp
->u
.p
.current_unit
->bytes_left
);
1659 if (is_stream_io(dtp
))
1667 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1669 write_i (dtp
, f
, p
, kind
);
1675 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1676 && require_numeric_type (dtp
, type
, f
))
1678 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1679 && require_type (dtp
, BT_INTEGER
, type
, f
))
1681 write_b (dtp
, f
, p
, kind
);
1687 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1688 && require_numeric_type (dtp
, type
, f
))
1690 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1691 && require_type (dtp
, BT_INTEGER
, type
, f
))
1693 write_o (dtp
, f
, p
, kind
);
1699 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1700 && require_numeric_type (dtp
, type
, f
))
1702 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1703 && require_type (dtp
, BT_INTEGER
, type
, f
))
1705 write_z (dtp
, f
, p
, kind
);
1712 /* It is possible to have FMT_A with something not BT_CHARACTER such
1713 as when writing out hollerith strings, so check both type
1714 and kind before calling wide character routines. */
1715 if (type
== BT_CHARACTER
&& kind
== 4)
1716 write_a_char4 (dtp
, f
, p
, size
);
1718 write_a (dtp
, f
, p
, size
);
1724 write_l (dtp
, f
, p
, kind
);
1730 if (require_type (dtp
, BT_REAL
, type
, f
))
1732 write_d (dtp
, f
, p
, kind
);
1738 if (require_type (dtp
, BT_REAL
, type
, f
))
1740 write_e (dtp
, f
, p
, kind
);
1746 if (require_type (dtp
, BT_REAL
, type
, f
))
1748 write_en (dtp
, f
, p
, kind
);
1754 if (require_type (dtp
, BT_REAL
, type
, f
))
1756 write_es (dtp
, f
, p
, kind
);
1762 if (require_type (dtp
, BT_REAL
, type
, f
))
1764 write_f (dtp
, f
, p
, kind
);
1773 write_i (dtp
, f
, p
, kind
);
1776 write_l (dtp
, f
, p
, kind
);
1780 write_a_char4 (dtp
, f
, p
, size
);
1782 write_a (dtp
, f
, p
, size
);
1785 if (f
->u
.real
.w
== 0)
1786 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1788 write_d (dtp
, f
, p
, kind
);
1791 internal_error (&dtp
->common
,
1792 "formatted_transfer(): Bad type");
1797 consume_data_flag
= 0;
1798 write_constant_string (dtp
, f
);
1801 /* Format codes that don't transfer data. */
1804 consume_data_flag
= 0;
1806 dtp
->u
.p
.skips
+= f
->u
.n
;
1807 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1808 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1809 /* Writes occur just before the switch on f->format, above, so
1810 that trailing blanks are suppressed, unless we are doing a
1811 non-advancing write in which case we want to output the blanks
1813 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1815 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1816 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1822 consume_data_flag
= 0;
1824 if (f
->format
== FMT_TL
)
1827 /* Handle the special case when no bytes have been used yet.
1828 Cannot go below zero. */
1829 if (bytes_used
== 0)
1831 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1832 dtp
->u
.p
.skips
-= f
->u
.n
;
1833 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1836 pos
= bytes_used
- f
->u
.n
;
1839 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1841 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1842 left tab limit. We do not check if the position has gone
1843 beyond the end of record because a subsequent tab could
1844 bring us back again. */
1845 pos
= pos
< 0 ? 0 : pos
;
1847 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1848 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1849 + pos
- dtp
->u
.p
.max_pos
;
1850 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1851 ? 0 : dtp
->u
.p
.pending_spaces
;
1855 consume_data_flag
= 0;
1856 dtp
->u
.p
.sign_status
= SIGN_S
;
1860 consume_data_flag
= 0;
1861 dtp
->u
.p
.sign_status
= SIGN_SS
;
1865 consume_data_flag
= 0;
1866 dtp
->u
.p
.sign_status
= SIGN_SP
;
1870 consume_data_flag
= 0 ;
1871 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1875 consume_data_flag
= 0;
1876 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1880 consume_data_flag
= 0;
1881 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1885 consume_data_flag
= 0;
1886 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1890 consume_data_flag
= 0;
1891 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1895 consume_data_flag
= 0;
1896 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1900 consume_data_flag
= 0;
1901 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1905 consume_data_flag
= 0;
1906 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1910 consume_data_flag
= 0;
1911 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1915 consume_data_flag
= 0;
1916 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1920 consume_data_flag
= 0;
1921 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1925 consume_data_flag
= 0;
1926 dtp
->u
.p
.seen_dollar
= 1;
1930 consume_data_flag
= 0;
1931 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1932 next_record (dtp
, 0);
1936 /* A colon descriptor causes us to exit this loop (in
1937 particular preventing another / descriptor from being
1938 processed) unless there is another data item to be
1940 consume_data_flag
= 0;
1946 internal_error (&dtp
->common
, "Bad format node");
1949 /* Adjust the item count and data pointer. */
1951 if ((consume_data_flag
> 0) && (n
> 0))
1954 p
= ((char *) p
) + size
;
1957 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1958 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1963 /* Come here when we need a data descriptor but don't have one. We
1964 push the current format node back onto the input, then return and
1965 let the user program call us back with the data. */
1967 unget_format (dtp
, f
);
1970 /* This function is first called from data_init_transfer to initiate the loop
1971 over each item in the format, transferring data as required. Subsequent
1972 calls to this function occur for each data item foound in the READ/WRITE
1973 statement. The item_count is incremented for each call. Since the first
1974 call is from data_transfer_init, the item_count is always one greater than
1975 the actual count number of the item being transferred. */
1978 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1979 size_t size
, size_t nelems
)
1985 size_t stride
= type
== BT_CHARACTER
?
1986 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1987 if (dtp
->u
.p
.mode
== READING
)
1989 /* Big loop over all the elements. */
1990 for (elem
= 0; elem
< nelems
; elem
++)
1992 dtp
->u
.p
.item_count
++;
1993 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1998 /* Big loop over all the elements. */
1999 for (elem
= 0; elem
< nelems
; elem
++)
2001 dtp
->u
.p
.item_count
++;
2002 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2008 /* Data transfer entry points. The type of the data entity is
2009 implicit in the subroutine call. This prevents us from having to
2010 share a common enum with the compiler. */
2013 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
2015 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2017 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
2021 transfer_integer_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2023 transfer_integer (dtp
, p
, kind
);
2027 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
2030 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2032 size
= size_from_real_kind (kind
);
2033 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
2037 transfer_real_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2039 transfer_real (dtp
, p
, kind
);
2043 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
2045 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2047 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
2051 transfer_logical_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2053 transfer_logical (dtp
, p
, kind
);
2057 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
2059 static char *empty_string
[0];
2061 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2064 /* Strings of zero length can have p == NULL, which confuses the
2065 transfer routines into thinking we need more data elements. To avoid
2066 this, we give them a nice pointer. */
2067 if (len
== 0 && p
== NULL
)
2070 /* Set kind here to 1. */
2071 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
2075 transfer_character_write (st_parameter_dt
*dtp
, void *p
, int len
)
2077 transfer_character (dtp
, p
, len
);
2081 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2083 static char *empty_string
[0];
2085 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2088 /* Strings of zero length can have p == NULL, which confuses the
2089 transfer routines into thinking we need more data elements. To avoid
2090 this, we give them a nice pointer. */
2091 if (len
== 0 && p
== NULL
)
2094 /* Here we pass the actual kind value. */
2095 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
2099 transfer_character_wide_write (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2101 transfer_character_wide (dtp
, p
, len
, kind
);
2105 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
2108 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2110 size
= size_from_complex_kind (kind
);
2111 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
2115 transfer_complex_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2117 transfer_complex (dtp
, p
, kind
);
2121 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2122 gfc_charlen_type charlen
)
2124 index_type count
[GFC_MAX_DIMENSIONS
];
2125 index_type extent
[GFC_MAX_DIMENSIONS
];
2126 index_type stride
[GFC_MAX_DIMENSIONS
];
2127 index_type stride0
, rank
, size
, n
;
2132 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2135 iotype
= (bt
) GFC_DESCRIPTOR_TYPE (desc
);
2136 size
= iotype
== BT_CHARACTER
? charlen
: GFC_DESCRIPTOR_SIZE (desc
);
2138 rank
= GFC_DESCRIPTOR_RANK (desc
);
2139 for (n
= 0; n
< rank
; n
++)
2142 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
2143 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
2145 /* If the extent of even one dimension is zero, then the entire
2146 array section contains zero elements, so we return after writing
2147 a zero array record. */
2152 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2157 stride0
= stride
[0];
2159 /* If the innermost dimension has a stride of 1, we can do the transfer
2160 in contiguous chunks. */
2161 if (stride0
== size
)
2166 data
= GFC_DESCRIPTOR_DATA (desc
);
2170 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2171 data
+= stride0
* tsize
;
2174 while (count
[n
] == extent
[n
])
2177 data
-= stride
[n
] * extent
[n
];
2194 transfer_array_write (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2195 gfc_charlen_type charlen
)
2197 transfer_array (dtp
, desc
, kind
, charlen
);
2200 /* Preposition a sequential unformatted file while reading. */
2203 us_read (st_parameter_dt
*dtp
, int continued
)
2210 if (compile_options
.record_marker
== 0)
2211 n
= sizeof (GFC_INTEGER_4
);
2213 n
= compile_options
.record_marker
;
2215 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
2216 if (unlikely (nr
< 0))
2218 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2224 return; /* end of file */
2226 else if (unlikely (n
!= nr
))
2228 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2232 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2233 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2237 case sizeof(GFC_INTEGER_4
):
2238 memcpy (&i4
, &i
, sizeof (i4
));
2242 case sizeof(GFC_INTEGER_8
):
2243 memcpy (&i8
, &i
, sizeof (i8
));
2248 runtime_error ("Illegal value for record marker");
2258 case sizeof(GFC_INTEGER_4
):
2259 memcpy (&u32
, &i
, sizeof (u32
));
2260 u32
= __builtin_bswap32 (u32
);
2261 memcpy (&i4
, &u32
, sizeof (i4
));
2265 case sizeof(GFC_INTEGER_8
):
2266 memcpy (&u64
, &i
, sizeof (u64
));
2267 u64
= __builtin_bswap64 (u64
);
2268 memcpy (&i8
, &u64
, sizeof (i8
));
2273 runtime_error ("Illegal value for record marker");
2280 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
2281 dtp
->u
.p
.current_unit
->continued
= 0;
2285 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
2286 dtp
->u
.p
.current_unit
->continued
= 1;
2290 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2294 /* Preposition a sequential unformatted file while writing. This
2295 amount to writing a bogus length that will be filled in later. */
2298 us_write (st_parameter_dt
*dtp
, int continued
)
2305 if (compile_options
.record_marker
== 0)
2306 nbytes
= sizeof (GFC_INTEGER_4
);
2308 nbytes
= compile_options
.record_marker
;
2310 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2311 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2313 /* For sequential unformatted, if RECL= was not specified in the OPEN
2314 we write until we have more bytes than can fit in the subrecord
2315 markers, then we write a new subrecord. */
2317 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2318 dtp
->u
.p
.current_unit
->recl_subrecord
;
2319 dtp
->u
.p
.current_unit
->continued
= continued
;
2323 /* Position to the next record prior to transfer. We are assumed to
2324 be before the next record. We also calculate the bytes in the next
2328 pre_position (st_parameter_dt
*dtp
)
2330 if (dtp
->u
.p
.current_unit
->current_record
)
2331 return; /* Already positioned. */
2333 switch (current_mode (dtp
))
2335 case FORMATTED_STREAM
:
2336 case UNFORMATTED_STREAM
:
2337 /* There are no records with stream I/O. If the position was specified
2338 data_transfer_init has already positioned the file. If no position
2339 was specified, we continue from where we last left off. I.e.
2340 there is nothing to do here. */
2343 case UNFORMATTED_SEQUENTIAL
:
2344 if (dtp
->u
.p
.mode
== READING
)
2351 case FORMATTED_SEQUENTIAL
:
2352 case FORMATTED_DIRECT
:
2353 case UNFORMATTED_DIRECT
:
2354 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2358 dtp
->u
.p
.current_unit
->current_record
= 1;
2362 /* Initialize things for a data transfer. This code is common for
2363 both reading and writing. */
2366 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2368 unit_flags u_flags
; /* Used for creating a unit if needed. */
2369 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2370 namelist_info
*ionml
;
2372 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2374 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2376 dtp
->u
.p
.ionml
= ionml
;
2377 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2379 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2382 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2383 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
2385 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2386 if (dtp
->u
.p
.current_unit
->s
== NULL
)
2387 { /* Open the unit with some default flags. */
2388 st_parameter_open opp
;
2391 if (dtp
->common
.unit
< 0)
2393 close_unit (dtp
->u
.p
.current_unit
);
2394 dtp
->u
.p
.current_unit
= NULL
;
2395 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2396 "Bad unit number in statement");
2399 memset (&u_flags
, '\0', sizeof (u_flags
));
2400 u_flags
.access
= ACCESS_SEQUENTIAL
;
2401 u_flags
.action
= ACTION_READWRITE
;
2403 /* Is it unformatted? */
2404 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2405 | IOPARM_DT_IONML_SET
)))
2406 u_flags
.form
= FORM_UNFORMATTED
;
2408 u_flags
.form
= FORM_UNSPECIFIED
;
2410 u_flags
.delim
= DELIM_UNSPECIFIED
;
2411 u_flags
.blank
= BLANK_UNSPECIFIED
;
2412 u_flags
.pad
= PAD_UNSPECIFIED
;
2413 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2414 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2415 u_flags
.async
= ASYNC_UNSPECIFIED
;
2416 u_flags
.round
= ROUND_UNSPECIFIED
;
2417 u_flags
.sign
= SIGN_UNSPECIFIED
;
2419 u_flags
.status
= STATUS_UNKNOWN
;
2421 conv
= get_unformatted_convert (dtp
->common
.unit
);
2423 if (conv
== GFC_CONVERT_NONE
)
2424 conv
= compile_options
.convert
;
2426 /* We use big_endian, which is 0 on little-endian machines
2427 and 1 on big-endian machines. */
2430 case GFC_CONVERT_NATIVE
:
2431 case GFC_CONVERT_SWAP
:
2434 case GFC_CONVERT_BIG
:
2435 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2438 case GFC_CONVERT_LITTLE
:
2439 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2443 internal_error (&opp
.common
, "Illegal value for CONVERT");
2447 u_flags
.convert
= conv
;
2449 opp
.common
= dtp
->common
;
2450 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2451 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2452 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2453 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2454 if (dtp
->u
.p
.current_unit
== NULL
)
2458 /* Check the action. */
2460 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2462 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2463 "Cannot read from file opened for WRITE");
2467 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2469 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2470 "Cannot write to file opened for READ");
2474 dtp
->u
.p
.first_item
= 1;
2476 /* Check the format. */
2478 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2481 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2482 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2485 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2486 "Format present for UNFORMATTED data transfer");
2490 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2492 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2494 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2495 "A format cannot be specified with a namelist");
2499 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2500 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2502 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2503 "Missing format for FORMATTED data transfer");
2507 if (is_internal_unit (dtp
)
2508 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2510 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2511 "Internal file cannot be accessed by UNFORMATTED "
2516 /* Check the record or position number. */
2518 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2519 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2521 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2522 "Direct access data transfer requires record number");
2526 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2528 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2530 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2531 "Record number not allowed for sequential access "
2536 if (compile_options
.warn_std
&&
2537 dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
)
2539 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2540 "Sequential READ or WRITE not allowed after "
2541 "EOF marker, possibly use REWIND or BACKSPACE");
2546 /* Process the ADVANCE option. */
2548 dtp
->u
.p
.advance_status
2549 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2550 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2551 "Bad ADVANCE parameter in data transfer statement");
2553 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2555 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2557 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2558 "ADVANCE specification conflicts with sequential "
2563 if (is_internal_unit (dtp
))
2565 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2566 "ADVANCE specification conflicts with internal file");
2570 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2571 != IOPARM_DT_HAS_FORMAT
)
2573 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2574 "ADVANCE specification requires an explicit format");
2581 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2583 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2585 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2586 "EOR specification requires an ADVANCE specification "
2591 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2592 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2594 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2595 "SIZE specification requires an ADVANCE "
2596 "specification of NO");
2601 { /* Write constraints. */
2602 if ((cf
& IOPARM_END
) != 0)
2604 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2605 "END specification cannot appear in a write "
2610 if ((cf
& IOPARM_EOR
) != 0)
2612 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2613 "EOR specification cannot appear in a write "
2618 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2620 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2621 "SIZE specification cannot appear in a write "
2627 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2628 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2630 /* Check the decimal mode. */
2631 dtp
->u
.p
.current_unit
->decimal_status
2632 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2633 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2634 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2637 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2638 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2640 /* Check the round mode. */
2641 dtp
->u
.p
.current_unit
->round_status
2642 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
2643 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
2644 round_opt
, "Bad ROUND parameter in data transfer "
2647 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
2648 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
2650 /* Check the sign mode. */
2651 dtp
->u
.p
.sign_status
2652 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2653 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2654 "Bad SIGN parameter in data transfer statement");
2656 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2657 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2659 /* Check the blank mode. */
2660 dtp
->u
.p
.blank_status
2661 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2662 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2664 "Bad BLANK parameter in data transfer statement");
2666 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2667 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2669 /* Check the delim mode. */
2670 dtp
->u
.p
.current_unit
->delim_status
2671 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2672 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2673 delim_opt
, "Bad DELIM parameter in data transfer statement");
2675 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2677 if (ionml
&& dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_UNSPECIFIED
)
2678 dtp
->u
.p
.current_unit
->delim_status
=
2679 compile_options
.allow_std
& GFC_STD_GNU
? DELIM_QUOTE
: DELIM_NONE
;
2681 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2684 /* Check the pad mode. */
2685 dtp
->u
.p
.current_unit
->pad_status
2686 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2687 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2688 "Bad PAD parameter in data transfer statement");
2690 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2691 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2693 /* Check to see if we might be reading what we wrote before */
2695 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2696 && !is_internal_unit (dtp
))
2698 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2700 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2701 sflush(dtp
->u
.p
.current_unit
->s
);
2704 /* Check the POS= specifier: that it is in range and that it is used with a
2705 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2707 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2709 if (is_stream_io (dtp
))
2714 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2715 "POS=specifier must be positive");
2719 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2721 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2722 "POS=specifier too large");
2726 dtp
->rec
= dtp
->pos
;
2728 if (dtp
->u
.p
.mode
== READING
)
2730 /* Reset the endfile flag; if we hit EOF during reading
2731 we'll set the flag and generate an error at that point
2732 rather than worrying about it here. */
2733 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2736 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2738 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2739 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
2741 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2744 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2749 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2750 "POS=specifier not allowed, "
2751 "Try OPEN with ACCESS='stream'");
2757 /* Sanity checks on the record number. */
2758 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2762 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2763 "Record number must be positive");
2767 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2769 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2770 "Record number too large");
2774 /* Make sure format buffer is reset. */
2775 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2776 fbuf_reset (dtp
->u
.p
.current_unit
);
2779 /* Check whether the record exists to be read. Only
2780 a partial record needs to exist. */
2782 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2783 * dtp
->u
.p
.current_unit
->recl
>= ssize (dtp
->u
.p
.current_unit
->s
))
2785 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2786 "Non-existing record number");
2790 /* Position the file. */
2791 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2792 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
2794 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2798 /* TODO: This is required to maintain compatibility between
2799 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
2801 if (is_stream_io (dtp
))
2802 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2804 /* TODO: Un-comment this code when ABI changes from 4.3.
2805 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
2807 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2808 "Record number not allowed for stream access "
2814 /* Bugware for badly written mixed C-Fortran I/O. */
2815 if (!is_internal_unit (dtp
))
2816 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2818 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2820 /* Set the maximum position reached from the previous I/O operation. This
2821 could be greater than zero from a previous non-advancing write. */
2822 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2827 /* Set up the subroutine that will handle the transfers. */
2831 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2832 dtp
->u
.p
.transfer
= unformatted_read
;
2835 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2837 dtp
->u
.p
.last_char
= EOF
- 1;
2838 dtp
->u
.p
.transfer
= list_formatted_read
;
2841 dtp
->u
.p
.transfer
= formatted_transfer
;
2846 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2847 dtp
->u
.p
.transfer
= unformatted_write
;
2850 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2851 dtp
->u
.p
.transfer
= list_formatted_write
;
2853 dtp
->u
.p
.transfer
= formatted_transfer
;
2857 /* Make sure that we don't do a read after a nonadvancing write. */
2861 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2863 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2864 "Cannot READ after a nonadvancing WRITE");
2870 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2871 dtp
->u
.p
.current_unit
->read_bad
= 1;
2874 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2876 #ifdef HAVE_USELOCALE
2877 dtp
->u
.p
.old_locale
= uselocale (c_locale
);
2879 __gthread_mutex_lock (&old_locale_lock
);
2880 if (!old_locale_ctr
++)
2882 old_locale
= setlocale (LC_NUMERIC
, NULL
);
2883 setlocale (LC_NUMERIC
, "C");
2885 __gthread_mutex_unlock (&old_locale_lock
);
2887 /* Start the data transfer if we are doing a formatted transfer. */
2888 if ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0
2889 && dtp
->u
.p
.ionml
== NULL
)
2890 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2895 /* Initialize an array_loop_spec given the array descriptor. The function
2896 returns the index of the last element of the array, and also returns
2897 starting record, where the first I/O goes to (necessary in case of
2898 negative strides). */
2901 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2902 gfc_offset
*start_record
)
2904 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2913 for (i
=0; i
<rank
; i
++)
2915 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2916 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2917 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
2918 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
2919 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
2920 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
2922 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
2924 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2925 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2929 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2930 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2931 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2932 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2942 /* Determine the index to the next record in an internal unit array by
2943 by incrementing through the array_loop_spec. */
2946 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2954 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2959 if (ls
[i
].idx
> ls
[i
].end
)
2961 ls
[i
].idx
= ls
[i
].start
;
2967 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2977 /* Skip to the end of the current record, taking care of an optional
2978 record marker of size bytes. If the file is not seekable, we
2979 read chunks of size MAX_READ until we get to the right
2983 skip_record (st_parameter_dt
*dtp
, ssize_t bytes
)
2985 ssize_t rlength
, readb
;
2986 #define MAX_READ 4096
2989 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2990 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2993 /* Direct access files do not generate END conditions,
2995 if (sseek (dtp
->u
.p
.current_unit
->s
,
2996 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
2998 /* Seeking failed, fall back to seeking by reading data. */
2999 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
3002 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
3003 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3005 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
3008 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3012 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
3016 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= 0;
3020 /* Advance to the next record reading unformatted files, taking
3021 care of subrecords. If complete_record is nonzero, we loop
3022 until all subrecords are cleared. */
3025 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
3029 bytes
= compile_options
.record_marker
== 0 ?
3030 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
3035 /* Skip over tail */
3037 skip_record (dtp
, bytes
);
3039 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
3048 min_off (gfc_offset a
, gfc_offset b
)
3050 return (a
< b
? a
: b
);
3054 /* Space to the next record for read mode. */
3057 next_record_r (st_parameter_dt
*dtp
, int done
)
3064 switch (current_mode (dtp
))
3066 /* No records in unformatted STREAM I/O. */
3067 case UNFORMATTED_STREAM
:
3070 case UNFORMATTED_SEQUENTIAL
:
3071 next_record_r_unf (dtp
, 1);
3072 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3075 case FORMATTED_DIRECT
:
3076 case UNFORMATTED_DIRECT
:
3077 skip_record (dtp
, dtp
->u
.p
.current_unit
->bytes_left
);
3080 case FORMATTED_STREAM
:
3081 case FORMATTED_SEQUENTIAL
:
3082 /* read_sf has already terminated input because of an '\n', or
3084 if (dtp
->u
.p
.sf_seen_eor
)
3086 dtp
->u
.p
.sf_seen_eor
= 0;
3090 if (is_internal_unit (dtp
))
3092 if (is_array_io (dtp
))
3096 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3098 if (!done
&& finished
)
3101 /* Now seek to this record. */
3102 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3103 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3105 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3108 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3112 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3113 bytes_left
= min_off (bytes_left
,
3114 ssize (dtp
->u
.p
.current_unit
->s
)
3115 - stell (dtp
->u
.p
.current_unit
->s
));
3116 if (sseek (dtp
->u
.p
.current_unit
->s
,
3117 bytes_left
, SEEK_CUR
) < 0)
3119 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3122 dtp
->u
.p
.current_unit
->bytes_left
3123 = dtp
->u
.p
.current_unit
->recl
;
3132 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
3136 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3139 if (is_stream_io (dtp
)
3140 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
3141 || dtp
->u
.p
.current_unit
->bytes_left
3142 == dtp
->u
.p
.current_unit
->recl
)
3148 if (is_stream_io (dtp
))
3149 dtp
->u
.p
.current_unit
->strm_pos
++;
3160 /* Small utility function to write a record marker, taking care of
3161 byte swapping and of choosing the correct size. */
3164 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
3170 if (compile_options
.record_marker
== 0)
3171 len
= sizeof (GFC_INTEGER_4
);
3173 len
= compile_options
.record_marker
;
3175 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
3176 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
3180 case sizeof (GFC_INTEGER_4
):
3182 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
3185 case sizeof (GFC_INTEGER_8
):
3187 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
3191 runtime_error ("Illegal value for record marker");
3201 case sizeof (GFC_INTEGER_4
):
3203 memcpy (&u32
, &buf4
, sizeof (u32
));
3204 u32
= __builtin_bswap32 (u32
);
3205 return swrite (dtp
->u
.p
.current_unit
->s
, &u32
, len
);
3208 case sizeof (GFC_INTEGER_8
):
3210 memcpy (&u64
, &buf8
, sizeof (u64
));
3211 u64
= __builtin_bswap64 (u64
);
3212 return swrite (dtp
->u
.p
.current_unit
->s
, &u64
, len
);
3216 runtime_error ("Illegal value for record marker");
3223 /* Position to the next (sub)record in write mode for
3224 unformatted sequential files. */
3227 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
3229 gfc_offset m
, m_write
, record_marker
;
3231 /* Bytes written. */
3232 m
= dtp
->u
.p
.current_unit
->recl_subrecord
3233 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3235 if (compile_options
.record_marker
== 0)
3236 record_marker
= sizeof (GFC_INTEGER_4
);
3238 record_marker
= compile_options
.record_marker
;
3240 /* Seek to the head and overwrite the bogus length with the real
3243 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- record_marker
,
3252 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3255 /* Seek past the end of the current record. */
3257 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
, SEEK_CUR
) < 0))
3260 /* Write the length tail. If we finish a record containing
3261 subrecords, we write out the negative length. */
3263 if (dtp
->u
.p
.current_unit
->continued
)
3268 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3274 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3280 /* Utility function like memset() but operating on streams. Return
3281 value is same as for POSIX write(). */
3284 sset (stream
* s
, int c
, ssize_t nbyte
)
3286 #define WRITE_CHUNK 256
3287 char p
[WRITE_CHUNK
];
3288 ssize_t bytes_left
, trans
;
3290 if (nbyte
< WRITE_CHUNK
)
3291 memset (p
, c
, nbyte
);
3293 memset (p
, c
, WRITE_CHUNK
);
3296 while (bytes_left
> 0)
3298 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
3299 trans
= swrite (s
, p
, trans
);
3302 bytes_left
-= trans
;
3305 return nbyte
- bytes_left
;
3309 /* Position to the next record in write mode. */
3312 next_record_w (st_parameter_dt
*dtp
, int done
)
3314 gfc_offset m
, record
, max_pos
;
3317 /* Zero counters for X- and T-editing. */
3318 max_pos
= dtp
->u
.p
.max_pos
;
3319 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
3321 switch (current_mode (dtp
))
3323 /* No records in unformatted STREAM I/O. */
3324 case UNFORMATTED_STREAM
:
3327 case FORMATTED_DIRECT
:
3328 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
3331 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3332 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
3333 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
3334 dtp
->u
.p
.current_unit
->bytes_left
)
3335 != dtp
->u
.p
.current_unit
->bytes_left
)
3340 case UNFORMATTED_DIRECT
:
3341 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
3343 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3344 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3349 case UNFORMATTED_SEQUENTIAL
:
3350 next_record_w_unf (dtp
, 0);
3351 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3354 case FORMATTED_STREAM
:
3355 case FORMATTED_SEQUENTIAL
:
3357 if (is_internal_unit (dtp
))
3360 if (is_array_io (dtp
))
3364 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3366 /* If the farthest position reached is greater than current
3367 position, adjust the position and set length to pad out
3368 whats left. Otherwise just pad whats left.
3369 (for character array unit) */
3370 m
= dtp
->u
.p
.current_unit
->recl
3371 - dtp
->u
.p
.current_unit
->bytes_left
;
3374 length
= (int) (max_pos
- m
);
3375 if (sseek (dtp
->u
.p
.current_unit
->s
,
3376 length
, SEEK_CUR
) < 0)
3378 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3381 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3384 p
= write_block (dtp
, length
);
3388 if (unlikely (is_char4_unit (dtp
)))
3390 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3391 memset4 (p4
, ' ', length
);
3394 memset (p
, ' ', length
);
3396 /* Now that the current record has been padded out,
3397 determine where the next record in the array is. */
3398 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3401 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3403 /* Now seek to this record */
3404 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3406 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3408 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3412 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3418 /* If this is the last call to next_record move to the farthest
3419 position reached and set length to pad out the remainder
3420 of the record. (for character scaler unit) */
3423 m
= dtp
->u
.p
.current_unit
->recl
3424 - dtp
->u
.p
.current_unit
->bytes_left
;
3427 length
= (int) (max_pos
- m
);
3428 if (sseek (dtp
->u
.p
.current_unit
->s
,
3429 length
, SEEK_CUR
) < 0)
3431 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3434 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3437 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3441 p
= write_block (dtp
, length
);
3445 if (unlikely (is_char4_unit (dtp
)))
3447 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3448 memset4 (p4
, (gfc_char4_t
) ' ', length
);
3451 memset (p
, ' ', length
);
3462 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3463 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3470 if (is_stream_io (dtp
))
3472 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3473 if (dtp
->u
.p
.current_unit
->strm_pos
3474 < ssize (dtp
->u
.p
.current_unit
->s
))
3475 unit_truncate (dtp
->u
.p
.current_unit
,
3476 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3484 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3489 /* Position to the next record, which means moving to the end of the
3490 current record. This can happen under several different
3491 conditions. If the done flag is not set, we get ready to process
3495 next_record (st_parameter_dt
*dtp
, int done
)
3497 gfc_offset fp
; /* File position. */
3499 dtp
->u
.p
.current_unit
->read_bad
= 0;
3501 if (dtp
->u
.p
.mode
== READING
)
3502 next_record_r (dtp
, done
);
3504 next_record_w (dtp
, done
);
3506 if (!is_stream_io (dtp
))
3508 /* Since we have changed the position, set it to unspecified so
3509 that INQUIRE(POSITION=) knows it needs to look into it. */
3511 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_UNSPECIFIED
;
3513 dtp
->u
.p
.current_unit
->current_record
= 0;
3514 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3516 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3517 /* Calculate next record, rounding up partial records. */
3518 dtp
->u
.p
.current_unit
->last_record
=
3519 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
3520 dtp
->u
.p
.current_unit
->recl
;
3523 dtp
->u
.p
.current_unit
->last_record
++;
3529 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3530 smarkeor (dtp
->u
.p
.current_unit
->s
);
3534 /* Finalize the current data transfer. For a nonadvancing transfer,
3535 this means advancing to the next record. For internal units close the
3536 stream associated with the unit. */
3539 finalize_transfer (st_parameter_dt
*dtp
)
3541 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3543 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3544 *dtp
->size
= dtp
->u
.p
.size_used
;
3546 if (dtp
->u
.p
.eor_condition
)
3548 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3552 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3554 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3555 dtp
->u
.p
.current_unit
->current_record
= 0;
3559 if ((dtp
->u
.p
.ionml
!= NULL
)
3560 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3562 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3563 namelist_read (dtp
);
3565 namelist_write (dtp
);
3568 dtp
->u
.p
.transfer
= NULL
;
3569 if (dtp
->u
.p
.current_unit
== NULL
)
3572 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3574 finish_list_read (dtp
);
3578 if (dtp
->u
.p
.mode
== WRITING
)
3579 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3580 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3582 if (is_stream_io (dtp
))
3584 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3585 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3586 next_record (dtp
, 1);
3591 dtp
->u
.p
.current_unit
->current_record
= 0;
3593 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3595 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3596 dtp
->u
.p
.seen_dollar
= 0;
3600 /* For non-advancing I/O, save the current maximum position for use in the
3601 next I/O operation if needed. */
3602 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3604 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3605 - dtp
->u
.p
.current_unit
->bytes_left
);
3606 dtp
->u
.p
.current_unit
->saved_pos
=
3607 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3608 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3611 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3612 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3613 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3615 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3617 next_record (dtp
, 1);
3620 #ifdef HAVE_USELOCALE
3621 if (dtp
->u
.p
.old_locale
!= (locale_t
) 0)
3623 uselocale (dtp
->u
.p
.old_locale
);
3624 dtp
->u
.p
.old_locale
= (locale_t
) 0;
3627 __gthread_mutex_lock (&old_locale_lock
);
3628 if (!--old_locale_ctr
)
3630 setlocale (LC_NUMERIC
, old_locale
);
3633 __gthread_mutex_unlock (&old_locale_lock
);
3637 /* Transfer function for IOLENGTH. It doesn't actually do any
3638 data transfer, it just updates the length counter. */
3641 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3642 void *dest
__attribute__ ((unused
)),
3643 int kind
__attribute__((unused
)),
3644 size_t size
, size_t nelems
)
3646 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3647 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3651 /* Initialize the IOLENGTH data transfer. This function is in essence
3652 a very much simplified version of data_transfer_init(), because it
3653 doesn't have to deal with units at all. */
3656 iolength_transfer_init (st_parameter_dt
*dtp
)
3658 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3661 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3663 /* Set up the subroutine that will handle the transfers. */
3665 dtp
->u
.p
.transfer
= iolength_transfer
;
3669 /* Library entry point for the IOLENGTH form of the INQUIRE
3670 statement. The IOLENGTH form requires no I/O to be performed, but
3671 it must still be a runtime library call so that we can determine
3672 the iolength for dynamic arrays and such. */
3674 extern void st_iolength (st_parameter_dt
*);
3675 export_proto(st_iolength
);
3678 st_iolength (st_parameter_dt
*dtp
)
3680 library_start (&dtp
->common
);
3681 iolength_transfer_init (dtp
);
3684 extern void st_iolength_done (st_parameter_dt
*);
3685 export_proto(st_iolength_done
);
3688 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3695 /* The READ statement. */
3697 extern void st_read (st_parameter_dt
*);
3698 export_proto(st_read
);
3701 st_read (st_parameter_dt
*dtp
)
3703 library_start (&dtp
->common
);
3705 data_transfer_init (dtp
, 1);
3708 extern void st_read_done (st_parameter_dt
*);
3709 export_proto(st_read_done
);
3712 st_read_done (st_parameter_dt
*dtp
)
3714 finalize_transfer (dtp
);
3715 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3716 free_format_data (dtp
->u
.p
.fmt
);
3718 if (dtp
->u
.p
.current_unit
!= NULL
)
3719 unlock_unit (dtp
->u
.p
.current_unit
);
3721 free_internal_unit (dtp
);
3726 extern void st_write (st_parameter_dt
*);
3727 export_proto(st_write
);
3730 st_write (st_parameter_dt
*dtp
)
3732 library_start (&dtp
->common
);
3733 data_transfer_init (dtp
, 0);
3736 extern void st_write_done (st_parameter_dt
*);
3737 export_proto(st_write_done
);
3740 st_write_done (st_parameter_dt
*dtp
)
3742 finalize_transfer (dtp
);
3744 /* Deal with endfile conditions associated with sequential files. */
3746 if (dtp
->u
.p
.current_unit
!= NULL
3747 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3748 switch (dtp
->u
.p
.current_unit
->endfile
)
3750 case AT_ENDFILE
: /* Remain at the endfile record. */
3754 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3758 /* Get rid of whatever is after this record. */
3759 if (!is_internal_unit (dtp
))
3760 unit_truncate (dtp
->u
.p
.current_unit
,
3761 stell (dtp
->u
.p
.current_unit
->s
),
3763 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3767 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3768 free_format_data (dtp
->u
.p
.fmt
);
3770 if (dtp
->u
.p
.current_unit
!= NULL
)
3771 unlock_unit (dtp
->u
.p
.current_unit
);
3773 free_internal_unit (dtp
);
3779 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3781 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3786 /* Receives the scalar information for namelist objects and stores it
3787 in a linked list of namelist_info types. */
3789 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3790 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3791 export_proto(st_set_nml_var
);
3795 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3796 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3797 GFC_INTEGER_4 dtype
)
3799 namelist_info
*t1
= NULL
;
3801 size_t var_name_len
= strlen (var_name
);
3803 nml
= (namelist_info
*) xmalloc (sizeof (namelist_info
));
3805 nml
->mem_pos
= var_addr
;
3807 nml
->var_name
= (char*) xmalloc (var_name_len
+ 1);
3808 memcpy (nml
->var_name
, var_name
, var_name_len
);
3809 nml
->var_name
[var_name_len
] = '\0';
3811 nml
->len
= (int) len
;
3812 nml
->string_length
= (index_type
) string_length
;
3814 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3815 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3816 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3818 if (nml
->var_rank
> 0)
3820 nml
->dim
= (descriptor_dimension
*)
3821 xmallocarray (nml
->var_rank
, sizeof (descriptor_dimension
));
3822 nml
->ls
= (array_loop_spec
*)
3823 xmallocarray (nml
->var_rank
, sizeof (array_loop_spec
));
3833 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3835 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3836 dtp
->u
.p
.ionml
= nml
;
3840 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3845 /* Store the dimensional information for the namelist object. */
3846 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3847 index_type
, index_type
,
3849 export_proto(st_set_nml_var_dim
);
3852 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3853 index_type stride
, index_type lbound
,
3856 namelist_info
* nml
;
3861 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3863 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
3867 /* Once upon a time, a poor innocent Fortran program was reading a
3868 file, when suddenly it hit the end-of-file (EOF). Unfortunately
3869 the OS doesn't tell whether we're at the EOF or whether we already
3870 went past it. Luckily our hero, libgfortran, keeps track of this.
3871 Call this function when you detect an EOF condition. See Section
3875 hit_eof (st_parameter_dt
* dtp
)
3877 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
3879 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3880 switch (dtp
->u
.p
.current_unit
->endfile
)
3884 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3885 if (!is_internal_unit (dtp
) && !dtp
->u
.p
.namelist_mode
)
3887 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3888 dtp
->u
.p
.current_unit
->current_record
= 0;
3891 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3895 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3896 dtp
->u
.p
.current_unit
->current_record
= 0;
3901 /* Non-sequential files don't have an ENDFILE record, so we
3902 can't be at AFTER_ENDFILE. */
3903 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3904 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3905 dtp
->u
.p
.current_unit
->current_record
= 0;